Fortran: Fix Explicit cobounds of a procedures parameter not respected [PR78466]

Explicit cobounds of class array procedure parameters were not taken
into account.  Furthermore were different cobounds in distinct
procedure parameter lists mixed up, i.e. the last definition was taken
for all.  The bounds are now regenerated when tree's and expr's bounds
do not match.

	PR fortran/78466
	PR fortran/80774

gcc/fortran/ChangeLog:

	* array.cc (gfc_compare_array_spec): Take cotype into account.
	* class.cc (gfc_build_class_symbol): Coarrays are also arrays.
	* gfortran.h (IS_CLASS_COARRAY_OR_ARRAY): New macro to detect
	regular and coarray class arrays.
	* interface.cc (compare_components): Take codimension into
	account.
	* resolve.cc (resolve_symbol): Improve error message.
	* simplify.cc (simplify_bound_dim): Remove duplicate.
	* trans-array.cc (gfc_trans_array_cobounds): Coarrays are also
	arrays.
	(gfc_trans_array_bounds): Same.
	(gfc_trans_dummy_array_bias): Same.
	(get_coarray_as): Get the as having a non-zero codim.
	(is_explicit_coarray): Detect explicit coarrays.
	(gfc_conv_expr_descriptor): Create a new descriptor for explicit
	coarrays.
	* trans-decl.cc (gfc_build_qualified_array): Coarrays are also
	arrays.
	(gfc_build_dummy_array_decl): Same.
	(gfc_get_symbol_decl): Same.
	(gfc_trans_deferred_vars): Same.
	* trans-expr.cc (class_scalar_coarray_to_class): Get the
	descriptor from the correct location.
	(gfc_conv_variable): Pick up the descriptor when needed.
	* trans-types.cc (gfc_is_nodesc_array): Coarrays are also
	arrays.
	(gfc_get_nodesc_array_type): Indentation fix only.
	(cobounds_match_decl): Match a tree's bounds to the expr's
	bounds and return true, when they match.
	(gfc_get_derived_type): Create a new type tree/descriptor, when
	the cobounds of the existing declaration and expr to not
	match.  This happends for class arrays in parameter list, when
	there are different cobound declarations.

gcc/testsuite/ChangeLog:

	* gfortran.dg/coarray/poly_run_1.f90: Activate old test code.
	* gfortran.dg/coarray/poly_run_2.f90: Activate test.  It was
	stopping before and passing without an error.

diff --git a/gcc/fortran/array.cc b/gcc/fortran/array.cc
index e9934f1491b20ff944a5afd897c345ed6ed2f52f..79c774d59a0b1d1a16910eaf5682d3d60a446277 100644 (file)
--- a/gcc/fortran/array.cc
+++ b/gcc/fortran/array.cc
@@ -1017,6 +1017,9 @@ gfc_compare_array_spec (gfc_array_spec *as1, gfc_array_spec *as2)
   if (as1->type != as2->type)
     return 0;
 
+  if (as1->cotype != as2->cotype)
+    return 0;
+
   if (as1->type == AS_EXPLICIT)
     for (i = 0; i < as1->rank + as1->corank; i++)
       {

diff --git a/gcc/fortran/class.cc b/gcc/fortran/class.cc
index abe89630be3c1c3e28bb49d3ab7e4744a7bea9be..b9dcc0a3d98c9d166b38cb2c4c6f1909cc4e5885 100644 (file)
--- a/gcc/fortran/class.cc
+++ b/gcc/fortran/class.cc
@@ -709,8 +709,12 @@ gfc_build_class_symbol (gfc_typespec *ts, symbol_attribute *attr,
      work on the declared type. All array type other than deferred shape or
      assumed rank are added to the function namespace to ensure that they
      are properly distinguished.  */
-  if (attr->dummy && !attr->codimension && (*as)
-      && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK))
+  if (attr->dummy && (*as)
+      && ((!attr->codimension
+          && !((*as)->type == AS_DEFERRED || (*as)->type == AS_ASSUMED_RANK))
+         || (attr->codimension
+             && !((*as)->cotype == AS_DEFERRED
+                  || (*as)->cotype == AS_ASSUMED_RANK))))
     {
       char *sname;
       ns = gfc_current_ns;

diff --git a/gcc/fortran/gfortran.h b/gcc/fortran/gfortran.h
index c1fb896f587e6e320fe69bb1c994a8765233a7de..3bdf18d6f9bc79d38cac2a0cd165ecf33cf4a111 100644 (file)
--- a/gcc/fortran/gfortran.h
+++ b/gcc/fortran/gfortran.h
@@ -4047,6 +4047,11 @@ bool gfc_may_be_finalized (gfc_typespec);
         && CLASS_DATA (sym) \
         && CLASS_DATA (sym)->attr.dimension \
         && !CLASS_DATA (sym)->attr.class_pointer)
+#define IS_CLASS_COARRAY_OR_ARRAY(sym) \
+       (sym->ts.type == BT_CLASS && CLASS_DATA (sym) \
+        && (CLASS_DATA (sym)->attr.dimension \
+            || CLASS_DATA (sym)->attr.codimension) \
+        && !CLASS_DATA (sym)->attr.class_pointer)
 #define IS_POINTER(sym) \
        (sym->ts.type == BT_CLASS && sym->attr.class_ok && CLASS_DATA (sym) \
         ? CLASS_DATA (sym)->attr.class_pointer : sym->attr.pointer)

diff --git a/gcc/fortran/interface.cc b/gcc/fortran/interface.cc
index bf151dae74390a0bb8165cd6b3380853320c703a..b592fe4f6c7f36a229feb059a3ea93cff88202d5 100644 (file)
--- a/gcc/fortran/interface.cc
+++ b/gcc/fortran/interface.cc
@@ -518,12 +518,19 @@ compare_components (gfc_component *cmp1, gfc_component *cmp2,
   if (cmp1->attr.dimension != cmp2->attr.dimension)
     return false;
 
+  if (cmp1->attr.codimension != cmp2->attr.codimension)
+    return false;
+
   if (cmp1->attr.allocatable != cmp2->attr.allocatable)
     return false;
 
   if (cmp1->attr.dimension && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0)
     return false;
 
+  if (cmp1->attr.codimension
+      && gfc_compare_array_spec (cmp1->as, cmp2->as) == 0)
+    return false;
+
   if (cmp1->ts.type == BT_CHARACTER && cmp2->ts.type == BT_CHARACTER)
     {
       gfc_charlen *l1 = cmp1->ts.u.cl;

diff --git a/gcc/fortran/resolve.cc b/gcc/fortran/resolve.cc
index 4f4fafa421719128bd896521e780fd0df09628eb..503029364c146c5d578c4f0ccce19dfc37b790df 100644 (file)
--- a/gcc/fortran/resolve.cc
+++ b/gcc/fortran/resolve.cc
@@ -16909,7 +16909,8 @@ resolve_symbol (gfc_symbol *sym)
           && !class_attr.allocatable && as && as->cotype == AS_DEFERRED)
     {
       gfc_error ("Coarray variable %qs at %L shall not have codimensions with "
-                "deferred shape", sym->name, &sym->declared_at);
+                "deferred shape without allocatable", sym->name,
+                &sym->declared_at);
       return;
     }
   else if (class_attr.codimension && class_attr.allocatable && as

diff --git a/gcc/fortran/simplify.cc b/gcc/fortran/simplify.cc
index 60b717fea9a7a3460770b0466714377a189fd189..8ddd491de113c47da5ffa4a0a4e5a5cfa5d894aa 100644 (file)
--- a/gcc/fortran/simplify.cc
+++ b/gcc/fortran/simplify.cc
@@ -4115,8 +4115,6 @@ simplify_bound_dim (gfc_expr *array, gfc_expr *kind, int d, int upper,
       goto returnNull;
     }
 
-  result = gfc_get_constant_expr (BT_INTEGER, k, &array->where);
-
   /* Then, we need to know the extent of the given dimension.  */
   if (coarray || (ref->u.ar.type == AR_FULL && !ref->next))
     {

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index 6d3b63b026c60be0a50780edd4a988f8666c249c..dc3de6c3b149e021231ef4f6993fe25d1456af3b 100644 (file)
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -6752,7 +6752,7 @@ gfc_trans_array_cobounds (tree type, stmtblock_t * pblock,
   gfc_se se;
   gfc_array_spec *as;
 
-  as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
+  as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
 
   for (dim = as->rank; dim < as->rank + as->corank; dim++)
     {
@@ -6801,7 +6801,7 @@ gfc_trans_array_bounds (tree type, gfc_symbol * sym, tree * poffset,
 
   int dim;
 
-  as = IS_CLASS_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
+  as = IS_CLASS_COARRAY_OR_ARRAY (sym) ? CLASS_DATA (sym)->as : sym->as;
 
   size = gfc_index_one_node;
   offset = gfc_index_zero_node;
@@ -7144,7 +7144,7 @@ gfc_trans_dummy_array_bias (gfc_symbol * sym, tree tmpdesc,
   int no_repack;
   bool optional_arg;
   gfc_array_spec *as;
-  bool is_classarray = IS_CLASS_ARRAY (sym);
+  bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
 
   /* Do nothing for pointer and allocatable arrays.  */
   if ((sym->ts.type != BT_CLASS && sym->attr.pointer)
@@ -7820,6 +7820,51 @@ walk_coarray (gfc_expr *e)
   return ss;
 }
 
+gfc_array_spec *
+get_coarray_as (const gfc_expr *e)
+{
+  gfc_array_spec *as;
+  gfc_symbol *sym = e->symtree->n.sym;
+  gfc_component *comp;
+
+  if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.codimension)
+    as = CLASS_DATA (sym)->as;
+  else if (sym->attr.codimension)
+    as = sym->as;
+  else
+    as = nullptr;
+
+  for (gfc_ref *ref = e->ref; ref; ref = ref->next)
+    {
+      switch (ref->type)
+       {
+       case REF_COMPONENT:
+         comp = ref->u.c.component;
+         if (comp->ts.type == BT_CLASS && CLASS_DATA (comp)->attr.codimension)
+           as = CLASS_DATA (comp)->as;
+         else if (comp->ts.type != BT_CLASS && comp->attr.codimension)
+           as = comp->as;
+         break;
+
+       case REF_ARRAY:
+       case REF_SUBSTRING:
+       case REF_INQUIRY:
+         break;
+       }
+    }
+
+  return as;
+}
+
+bool
+is_explicit_coarray (gfc_expr *expr)
+{
+  if (!gfc_is_coarray (expr))
+    return false;
+
+  gfc_array_spec *cas = get_coarray_as (expr);
+  return cas && cas->cotype == AS_EXPLICIT;
+}
 
 /* Convert an array for passing as an actual argument.  Expressions and
    vector subscripts are evaluated and stored in a temporary, which is then
@@ -7934,6 +7979,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 
       if (need_tmp)
        full = 0;
+      else if (is_explicit_coarray (expr))
+       full = 0;
       else if (GFC_ARRAY_TYPE_P (TREE_TYPE (desc)))
        {
          /* Create a new descriptor if the array doesn't have one.  */

diff --git a/gcc/fortran/trans-decl.cc b/gcc/fortran/trans-decl.cc
index 54ab60b4935b840c0836deb72a233df677e3858c..e6ac7f25b3b00f573fb78754731beae07629aaf9 100644 (file)
--- a/gcc/fortran/trans-decl.cc
+++ b/gcc/fortran/trans-decl.cc
@@ -1016,7 +1016,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
   gfc_namespace* procns;
   symbol_attribute *array_attr;
   gfc_array_spec *as;
-  bool is_classarray = IS_CLASS_ARRAY (sym);
+  bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
 
   type = TREE_TYPE (decl);
   array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
@@ -1134,7 +1134,7 @@ gfc_build_qualified_array (tree decl, gfc_symbol * sym)
        gfc_add_decl_to_function (GFC_TYPE_ARRAY_OFFSET (type));
     }
 
-  if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE
+  if (GFC_TYPE_ARRAY_SIZE (type) == NULL_TREE && as->rank != 0
       && as->type != AS_ASSUMED_SIZE)
     {
       GFC_TYPE_ARRAY_SIZE (type) = create_index_var ("size", nest);
@@ -1238,7 +1238,7 @@ gfc_build_dummy_array_decl (gfc_symbol * sym, tree dummy)
   gfc_packed packed;
   int n;
   bool known_size;
-  bool is_classarray = IS_CLASS_ARRAY (sym);
+  bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
 
   /* Use the array as and attr.  */
   as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
@@ -1760,7 +1760,7 @@ gfc_get_symbol_decl (gfc_symbol * sym)
         sym->backend_decl's GFC_DECL_SAVED_DESCRIPTOR.  The caller is then
         responsible to extract it from there, when the descriptor is
         desired.  */
-      if (IS_CLASS_ARRAY (sym)
+      if (IS_CLASS_COARRAY_OR_ARRAY (sym)
          && (!DECL_LANG_SPECIFIC (sym->backend_decl)
              || !GFC_DECL_SAVED_DESCRIPTOR (sym->backend_decl)))
        {
@@ -1775,10 +1775,11 @@ gfc_get_symbol_decl (gfc_symbol * sym)
       if (sym->attr.assign && GFC_DECL_ASSIGN (sym->backend_decl) == 0)
        gfc_add_assign_aux_vars (sym);
 
-      if (sym->ts.type == BT_CLASS && sym->backend_decl)
-       GFC_DECL_CLASS(sym->backend_decl) = 1;
+      if (sym->ts.type == BT_CLASS && sym->backend_decl
+         && !IS_CLASS_COARRAY_OR_ARRAY (sym))
+       GFC_DECL_CLASS (sym->backend_decl) = 1;
 
-     return sym->backend_decl;
+      return sym->backend_decl;
     }
 
   if (sym->result == sym && sym->attr.assign
@@ -4889,9 +4890,10 @@ gfc_trans_deferred_vars (gfc_symbol * proc_sym, gfc_wrapped_block * block)
          TREE_CONSTANT (DECL_INITIAL (sym->backend_decl)) = 1;
        }
       else if ((sym->attr.dimension || sym->attr.codimension
-              || (IS_CLASS_ARRAY (sym) && !CLASS_DATA (sym)->attr.allocatable)))
+               || (IS_CLASS_COARRAY_OR_ARRAY (sym)
+                   && !CLASS_DATA (sym)->attr.allocatable)))
        {
-         bool is_classarray = IS_CLASS_ARRAY (sym);
+         bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
          symbol_attribute *array_attr;
          gfc_array_spec *as;
          array_type type_of_array;

diff --git a/gcc/fortran/trans-expr.cc b/gcc/fortran/trans-expr.cc
index 4102567425374b4971f325a585153eccb29a6cf7..d9eb333abcb1994ecede825fba54a51ea02affd8 100644 (file)
--- a/gcc/fortran/trans-expr.cc
+++ b/gcc/fortran/trans-expr.cc
@@ -1018,7 +1018,10 @@ class_scalar_coarray_to_class (gfc_se *parmse, gfc_expr *e,
                  fold_convert (TREE_TYPE (ctree), gfc_class_vptr_get (tmp)));
 
   ctree = gfc_class_data_get (var);
-  tmp = gfc_conv_descriptor_data_get (gfc_class_data_get (tmp));
+  tmp = gfc_conv_descriptor_data_get (
+    gfc_class_data_get (GFC_CLASS_TYPE_P (TREE_TYPE (TREE_TYPE (tmp)))
+                         ? tmp
+                         : GFC_DECL_SAVED_DESCRIPTOR (tmp)));
   gfc_add_modify (&block, ctree, fold_convert (TREE_TYPE (ctree), tmp));
 
   /* Pass the address of the class object.  */
@@ -3110,7 +3113,7 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
   bool first_time = true;
 
   sym = expr->symtree->n.sym;
-  is_classarray = IS_CLASS_ARRAY (sym);
+  is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
   ss = se->ss;
   if (ss != NULL)
     {
@@ -3201,11 +3204,24 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
       if (sym->ts.type == BT_CLASS
          && sym->attr.class_ok
          && sym->ts.u.derived->attr.is_class)
-       se->class_container = se->expr;
+       {
+         if (is_classarray && DECL_LANG_SPECIFIC (se->expr)
+             && GFC_DECL_SAVED_DESCRIPTOR (se->expr))
+           se->class_container = GFC_DECL_SAVED_DESCRIPTOR (se->expr);
+         else
+           se->class_container = se->expr;
+       }
 
       /* Dereference the expression, where needed.  */
-      se->expr = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
-                                           is_classarray);
+      if (se->class_container && CLASS_DATA (sym)->attr.codimension
+         && !CLASS_DATA (sym)->attr.dimension)
+       se->expr
+         = gfc_maybe_dereference_var (sym, se->class_container,
+                                      se->descriptor_only, is_classarray);
+      else
+       se->expr
+         = gfc_maybe_dereference_var (sym, se->expr, se->descriptor_only,
+                                      is_classarray);
 
       ref = expr->ref;
     }
@@ -3248,11 +3264,9 @@ gfc_conv_variable (gfc_se * se, gfc_expr * expr)
 
        case REF_COMPONENT:
          ts = &ref->u.c.component->ts;
-         if (first_time && is_classarray && sym->attr.dummy
-             && se->descriptor_only
-             && !CLASS_DATA (sym)->attr.allocatable
-             && !CLASS_DATA (sym)->attr.class_pointer
-             && CLASS_DATA (sym)->as
+         if (first_time && IS_CLASS_ARRAY (sym) && sym->attr.dummy
+             && se->descriptor_only && !CLASS_DATA (sym)->attr.allocatable
+             && !CLASS_DATA (sym)->attr.class_pointer && CLASS_DATA (sym)->as
              && CLASS_DATA (sym)->as->type != AS_ASSUMED_RANK
              && strcmp ("_data", ref->u.c.component->name) == 0)
            /* Skip the first ref of a _data component, because for class

diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 01ce54f0ac0ad7ef1d7ea7756fc0eea0fbf40e7f..59d72136a0de06cd75700e4062df3044187c3c6b 100644 (file)
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1395,7 +1395,7 @@ gfc_is_nodesc_array (gfc_symbol * sym)
 {
   symbol_attribute *array_attr;
   gfc_array_spec *as;
-  bool is_classarray = IS_CLASS_ARRAY (sym);
+  bool is_classarray = IS_CLASS_COARRAY_OR_ARRAY (sym);
 
   array_attr = is_classarray ? &CLASS_DATA (sym)->attr : &sym->attr;
   as = is_classarray ? CLASS_DATA (sym)->as : sym->as;
@@ -1766,7 +1766,7 @@ gfc_get_nodesc_array_type (tree etype, gfc_array_spec * as, gfc_packed packed,
       else
        tmp = NULL_TREE;
       if (n < as->rank + as->corank - 1)
-      GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
+       GFC_TYPE_ARRAY_UBOUND (type, n) = tmp;
     }
 
   if (known_offset)
@@ -2600,6 +2600,53 @@ gfc_get_union_type (gfc_symbol *un)
     return typenode;
 }
 
+bool
+cobounds_match_decl (const gfc_symbol *derived)
+{
+  tree arrtype, tmp;
+  gfc_array_spec *as;
+
+  if (!derived->backend_decl)
+    return false;
+  /* Care only about coarray declarations.  Everything else is ok with us.  */
+  if (!derived->components || strcmp (derived->components->name, "_data") != 0)
+    return true;
+  if (!derived->components->attr.codimension)
+    return true;
+
+  arrtype = TREE_TYPE (TYPE_FIELDS (derived->backend_decl));
+  as = derived->components->as;
+  if (GFC_TYPE_ARRAY_CORANK (arrtype) != as->corank)
+    return false;
+
+  for (int dim = as->rank; dim < as->rank + as->corank; ++dim)
+    {
+      /* Check lower bound.  */
+      tmp = TYPE_LANG_SPECIFIC (arrtype)->lbound[dim];
+      if (!tmp || !INTEGER_CST_P (tmp))
+       return false;
+      if (as->lower[dim]->expr_type != EXPR_CONSTANT
+         || as->lower[dim]->ts.type != BT_INTEGER)
+       return false;
+      if (*tmp->int_cst.val != mpz_get_si (as->lower[dim]->value.integer))
+       return false;
+
+      /* Check upper bound.  */
+      tmp = TYPE_LANG_SPECIFIC (arrtype)->ubound[dim];
+      if (!tmp && !as->upper[dim])
+       continue;
+
+      if (!tmp || !INTEGER_CST_P (tmp))
+       return false;
+      if (as->upper[dim]->expr_type != EXPR_CONSTANT
+         || as->upper[dim]->ts.type != BT_INTEGER)
+       return false;
+      if (*tmp->int_cst.val != mpz_get_si (as->upper[dim]->value.integer))
+       return false;
+    }
+
+  return true;
+}
 
 /* Build a tree node for a derived type.  If there are equal
    derived types, with different local names, these are built
@@ -2617,10 +2664,15 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
   gfc_component *c;
   gfc_namespace *ns;
   tree tmp;
-  bool coarray_flag;
+  bool coarray_flag, class_coarray_flag;
 
   coarray_flag = flag_coarray == GFC_FCOARRAY_LIB
                 && derived->module && !derived->attr.vtype;
+  class_coarray_flag = derived->components
+                      && derived->components->ts.type == BT_DERIVED
+                      && strcmp (derived->components->name, "_data") == 0
+                      && derived->components->attr.codimension
+                      && derived->components->as->cotype == AS_EXPLICIT;
 
   gcc_assert (!derived->attr.pdt_template);
 
@@ -2709,13 +2761,14 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
 
   /* derived->backend_decl != 0 means we saw it before, but its
      components' backend_decl may have not been built.  */
-  if (derived->backend_decl)
+  if (derived->backend_decl
+      && (!class_coarray_flag || cobounds_match_decl (derived)))
     {
       /* Its components' backend_decl have been built or we are
         seeing recursion through the formal arglist of a procedure
         pointer component.  */
       if (TYPE_FIELDS (derived->backend_decl))
-        return derived->backend_decl;
+       return derived->backend_decl;
       else if (derived->attr.abstract
               && derived->attr.proc_pointer_comp)
        {
@@ -2797,7 +2850,7 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
         }
     }
 
-  if (TYPE_FIELDS (derived->backend_decl))
+  if (!class_coarray_flag && TYPE_FIELDS (derived->backend_decl))
     return derived->backend_decl;
 
   /* Build the type member list. Install the newly created RECORD_TYPE
@@ -2904,12 +2957,13 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
       DECL_PACKED (field) |= TYPE_PACKED (typenode);
 
       gcc_assert (field);
-      if (!c->backend_decl)
+      /* Overwrite for class array to supply different bounds for different
+        types.  */
+      if (class_coarray_flag || !c->backend_decl)
        c->backend_decl = field;
 
-      if (c->attr.pointer && c->attr.dimension
-         && !(c->ts.type == BT_DERIVED
-              && strcmp (c->name, "_data") == 0))
+      if (c->attr.pointer && (c->attr.dimension || c->attr.codimension)
+         && !(c->ts.type == BT_DERIVED && strcmp (c->name, "_data") == 0))
        GFC_DECL_PTR_ARRAY_P (c->backend_decl) = 1;
     }
 

diff --git a/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90 b/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90
index 43525d96663397406b2aef4d6c51bec03192657b..f5354b89ca585edeb720ef74ffc8969c5b92261b 100644 (file)
--- a/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90
+++ b/gcc/testsuite/gfortran.dg/coarray/poly_run_1.f90
@@ -14,7 +14,7 @@ else
 end if
 if (allocated(A)) i = 5
 call s(A)
-!call st(A) ! FIXME
+call st(A) ! FIXME
 
 contains
 
@@ -30,22 +30,21 @@ end subroutine s
 
 subroutine st(x)
   class(t) :: x(:)[4,2:*]
-! FIXME
-!  if (any (lcobound(x) /= [1, 2])) STOP 7
-!  if (lcobound(x, dim=1) /= 1) STOP 8
-!  if (lcobound(x, dim=2) /= 2) STOP 9
-!  if (this_image() == 1) then
-!     if (any (this_image(x) /= lcobound(x))) STOP 10
-!     if (this_image(x, dim=1) /= lcobound(x, dim=1)) STOP 11
-!     if (this_image(x, dim=2) /= lcobound(x, dim=2)) STOP 12
-!  end if
-!  if (num_images() == 1) then
-!     if (any (ucobound(x) /= [4, 2])) STOP 13
-!     if (ucobound(x, dim=1) /= 4) STOP 14
-!     if (ucobound(x, dim=2) /= 2) STOP 15
-!  else
-!    if (ucobound(x,dim=1) /= 4) STOP 16
-!  end if
+  if (any (lcobound(x) /= [1, 2])) STOP 7
+  if (lcobound(x, dim=1) /= 1) STOP 8
+  if (lcobound(x, dim=2) /= 2) STOP 9
+  if (this_image() == 1) then
+     if (any (this_image(x) /= lcobound(x))) STOP 10
+     if (this_image(x, dim=1) /= lcobound(x, dim=1)) STOP 11
+     if (this_image(x, dim=2) /= lcobound(x, dim=2)) STOP 12
+  end if
+  if (num_images() == 1) then
+     if (any (ucobound(x) /= [4, 2])) STOP 13
+     if (ucobound(x, dim=1) /= 4) STOP 14
+     if (ucobound(x, dim=2) /= 2) STOP 15
+  else
+    if (ucobound(x,dim=1) /= 4) STOP 16
+  end if
 end subroutine st
 end
 

diff --git a/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90 b/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90
index 48a6f7b4cc04b4bdd02dea54e7cb67a53e25f10a..37347cba6aa22d5ced30fe35233fff667c205313 100644 (file)
--- a/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90
+++ b/gcc/testsuite/gfortran.dg/coarray/poly_run_2.f90
@@ -6,16 +6,16 @@ type t
 end type t
 class(t), allocatable :: A[:,:]
 allocate (A[1:4,-5:*])
-if (allocated(A)) stop
 if (any (lcobound(A) /= [1, -5])) STOP 1
 if (num_images() == 1) then
   if (any (ucobound(A) /= [4, -5])) STOP 2
 else
   if (ucobound(A,dim=1) /= 4) STOP 3
 end if
-if (allocated(A)) i = 5
+
 call s(A)
-call st(A)
+call s2(A)
+call sa(A)
 contains
 subroutine s(x)
   class(t) :: x[4,2:*]
@@ -26,14 +26,24 @@ subroutine s(x)
     if (ucobound(x,dim=1) /= 4) STOP 6
   end if
 end subroutine s
-subroutine st(x)
-  class(t) :: x[:,:]
-  if (any (lcobound(x) /= [1, -5])) STOP 7
+subroutine s2(x)
+  ! Check that different cobounds are set correctly.
+  class(t) :: x[2:5,7:*]
+  if (any (lcobound(x) /= [2, 7])) STOP 7
+  if (num_images() == 1) then
+    if (any (ucobound(x) /= [5, 7])) STOP 8
+  else
+    if (ucobound(x,dim=1) /= 5) STOP 9
+  end if
+end subroutine s2
+subroutine sa(x)
+  class(t), allocatable :: x[:,:]
+  if (any (lcobound(x) /= [1, -5])) STOP 10
   if (num_images() == 1) then
-    if (any (ucobound(x) /= [4, -5])) STOP 8
+    if (any (ucobound(x) /= [4, -5])) STOP 11
   else
-    if (ucobound(x,dim=1) /= 4) STOP 9
+    if (ucobound(x,dim=1) /= 4) STOP 12
   end if
-end subroutine st
+end subroutine sa
 end