Fortran: Improve gfc_array_kind for assumed rank; gfc_tree_array_size on 'tree'

Improve the internal and debug representation of assumed-rank arrays by
honoring the pointer and allocatable property.

Permit obtaining the array size from only a tree (via the array descriptor)
besides obtaining it from the gfc_expr's array spec. This will be used
by a follow up OpenMP patch for mapping derived types with allocatable
components.

gcc/fortran/ChangeLog:

	* trans-array.cc (gfc_full_array_size): Obtain the rank from
	the array descriptor for assumed rank.
	(gfc_tree_array_size): Likewise; permit expr = NULL to operate
	only the tree.
	(gfc_conv_descriptor_stride_get): Update for added assumed-rank
	array types.
	* trans-openmp.cc (gfc_omp_finish_clause): Likewise.
	* trans-types.cc (gfc_build_array_type, gfc_get_derived_type,
	gfc_get_array_descr_info): Likewise.
	* trans.h (enum gfc_array_kind): Add
	GFC_ARRAY_ASSUMED_RANK_{ALLOCATABLE,POINTER{,_CONT}}.

diff --git a/gcc/fortran/trans-array.cc b/gcc/fortran/trans-array.cc
index ec627dddffd435056815ee79d58791b2fa163c61..92e933add8a84135cb23bb20e71e156afab39806 100644 (file)
--- a/gcc/fortran/trans-array.cc
+++ b/gcc/fortran/trans-array.cc
@@ -483,9 +483,11 @@ gfc_conv_descriptor_stride_get (tree desc, tree dim)
   gcc_assert (GFC_DESCRIPTOR_TYPE_P (type));
   if (integer_zerop (dim)
       && (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
-         ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
-         ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
-         ||GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
+         || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT
+         || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT
+         || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+         || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
+         || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT))
     return gfc_index_one_node;
 
   return gfc_conv_descriptor_stride (desc, dim);
@@ -8746,7 +8748,8 @@ gfc_conv_expr_descriptor (gfc_se *se, gfc_expr *expr)
 
 
 /* Calculate the array size (number of elements); if dim != NULL_TREE,
-   return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).  */
+   return size for that dim (dim=0..rank-1; only for GFC_DESCRIPTOR_TYPE_P).
+   If !expr && descriptor array, the rank is taken from the descriptor.  */
 tree
 gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
 {
@@ -8756,20 +8759,15 @@ gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
       return GFC_TYPE_ARRAY_SIZE (TREE_TYPE (desc));
     }
   tree size, tmp, rank = NULL_TREE, cond = NULL_TREE;
-  symbol_attribute attr = gfc_expr_attr (expr);
-  gfc_array_spec *as = gfc_get_full_arrayspec_from_expr (expr);
   gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc)));
-  if ((!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
-       || !dim)
-    {
-      if (expr->rank < 0)
-       rank = fold_convert (signed_char_type_node,
-                            gfc_conv_descriptor_rank (desc));
-      else
-       rank = build_int_cst (signed_char_type_node, expr->rank);
-    }
+  enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (TREE_TYPE (desc));
+  if (expr == NULL || expr->rank < 0)
+    rank = fold_convert (signed_char_type_node,
+                        gfc_conv_descriptor_rank (desc));
+  else
+    rank = build_int_cst (signed_char_type_node, expr->rank);
 
-  if (dim || expr->rank == 1)
+  if (dim || (expr && expr->rank == 1))
     {
       if (!dim)
        dim = gfc_index_zero_node;
@@ -8786,8 +8784,8 @@ gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
           size = max (0, size);  */
       size = fold_build2_loc (input_location, MAX_EXPR, gfc_array_index_type,
                              size, gfc_index_zero_node);
-      if (!attr.pointer && !attr.allocatable
-         && as && as->type == AS_ASSUMED_RANK)
+      if (akind == GFC_ARRAY_ASSUMED_RANK_CONT
+         || akind == GFC_ARRAY_ASSUMED_RANK)
        {
          tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
                                 rank, build_int_cst (signed_char_type_node, 1));
@@ -8828,7 +8826,7 @@ gfc_tree_array_size (stmtblock_t *block, tree desc, gfc_expr *expr, tree dim)
           extent = 0
       size *= extent.  */
   cond = NULL_TREE;
-  if (!attr.pointer && !attr.allocatable && as && as->type == AS_ASSUMED_RANK)
+  if (akind == GFC_ARRAY_ASSUMED_RANK_CONT || akind == GFC_ARRAY_ASSUMED_RANK)
     {
       tmp = fold_build2_loc (input_location, MINUS_EXPR, signed_char_type_node,
                             rank, build_int_cst (signed_char_type_node, 1));
@@ -9456,7 +9454,10 @@ gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
   tree idx;
   tree nelems;
   tree tmp;
-  idx = gfc_rank_cst[rank - 1];
+  if (rank < 0)
+    idx = gfc_conv_descriptor_rank (decl);
+  else
+    idx = gfc_rank_cst[rank - 1];
   nelems = gfc_conv_descriptor_ubound_get (decl, idx);
   tmp = gfc_conv_descriptor_lbound_get (decl, idx);
   tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type,

diff --git a/gcc/fortran/trans-openmp.cc b/gcc/fortran/trans-openmp.cc
index 233cc0fcaa97f88956048f6a9f3dede2159b4e7f..3e5f92fe2e3425630baf9054256561878c7b9f34 100644 (file)
--- a/gcc/fortran/trans-openmp.cc
+++ b/gcc/fortran/trans-openmp.cc
@@ -1664,16 +1664,23 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
       tree size = create_tmp_var (gfc_array_index_type);
       tree elemsz = TYPE_SIZE_UNIT (gfc_get_element_type (type));
       elemsz = fold_convert (gfc_array_index_type, elemsz);
-      if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE
-         || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
-         || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
+      enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (type);
+      if (akind == GFC_ARRAY_ALLOCATABLE
+         || akind == GFC_ARRAY_POINTER
+         || akind == GFC_ARRAY_POINTER_CONT
+         || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+         || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+         || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
        {
          stmtblock_t cond_block;
          tree tem, then_b, else_b, zero, cond;
 
+         int rank = ((akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+                      || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+                      || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
+                     ? -1 : GFC_TYPE_ARRAY_RANK (type));
          gfc_init_block (&cond_block);
-         tem = gfc_full_array_size (&cond_block, decl,
-                                    GFC_TYPE_ARRAY_RANK (type));
+         tem = gfc_full_array_size (&cond_block, unshare_expr (decl), rank);
          gfc_add_modify (&cond_block, size, tem);
          gfc_add_modify (&cond_block, size,
                          fold_build2 (MULT_EXPR, gfc_array_index_type,
@@ -1683,7 +1690,7 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
          zero = build_int_cst (gfc_array_index_type, 0);
          gfc_add_modify (&cond_block, size, zero);
          else_b = gfc_finish_block (&cond_block);
-         tem = gfc_conv_descriptor_data_get (decl);
+         tem = gfc_conv_descriptor_data_get (unshare_expr (decl));
          tem = fold_convert (pvoid_type_node, tem);
          cond = fold_build2_loc (input_location, NE_EXPR,
                                  boolean_type_node, tem, null_pointer_node);
@@ -1701,10 +1708,13 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
          stmtblock_t cond_block;
          tree then_b;
 
+         int rank = ((akind == GFC_ARRAY_ASSUMED_RANK
+                      || akind == GFC_ARRAY_ASSUMED_RANK_CONT)
+                     ? -1 : GFC_TYPE_ARRAY_RANK (type));
          gfc_init_block (&cond_block);
          gfc_add_modify (&cond_block, size,
-                         gfc_full_array_size (&cond_block, decl,
-                                              GFC_TYPE_ARRAY_RANK (type)));
+                         gfc_full_array_size (&cond_block, unshare_expr (decl),
+                                              rank));
          gfc_add_modify (&cond_block, size,
                          fold_build2 (MULT_EXPR, gfc_array_index_type,
                                       size, elemsz));
@@ -1715,9 +1725,12 @@ gfc_omp_finish_clause (tree c, gimple_seq *pre_p, bool openacc)
        }
       else
        {
+         int rank = ((akind == GFC_ARRAY_ASSUMED_RANK
+                      || akind == GFC_ARRAY_ASSUMED_RANK_CONT)
+                     ? -1 : GFC_TYPE_ARRAY_RANK (type));
          gfc_add_modify (&block, size,
-                         gfc_full_array_size (&block, decl,
-                                              GFC_TYPE_ARRAY_RANK (type)));
+                         gfc_full_array_size (&block, unshare_expr (decl),
+                                              rank));
          gfc_add_modify (&block, size,
                          fold_build2 (MULT_EXPR, gfc_array_index_type,
                                       size, elemsz));

diff --git a/gcc/fortran/trans-types.cc b/gcc/fortran/trans-types.cc
index 0411400e0f2401f81c6a196e0dc3939511b01e26..3374778cb6500a7b6e77ac6b413c1a0a10973c6c 100644 (file)
--- a/gcc/fortran/trans-types.cc
+++ b/gcc/fortran/trans-types.cc
@@ -1628,8 +1628,16 @@ gfc_build_array_type (tree type, gfc_array_spec * as,
     akind = contiguous ? GFC_ARRAY_ASSUMED_SHAPE_CONT
                       : GFC_ARRAY_ASSUMED_SHAPE;
   else if (as->type == AS_ASSUMED_RANK)
-    akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
-                      : GFC_ARRAY_ASSUMED_RANK;
+    {
+      if (akind == GFC_ARRAY_ALLOCATABLE)
+       akind = GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE;
+      else if (akind == GFC_ARRAY_POINTER || akind == GFC_ARRAY_POINTER_CONT)
+       akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_POINTER_CONT
+                          : GFC_ARRAY_ASSUMED_RANK_POINTER;
+      else
+       akind = contiguous ? GFC_ARRAY_ASSUMED_RANK_CONT
+                          : GFC_ARRAY_ASSUMED_RANK;
+    }
   return gfc_get_array_type_bounds (type, as->rank == -1
                                          ? GFC_MAX_DIMENSIONS : as->rank,
                                    corank, lbound, ubound, 0, akind,
@@ -2958,9 +2966,10 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
     }
 
   if (derived->components
-       && derived->components->ts.type == BT_DERIVED
-       && strcmp (derived->components->name, "_data") == 0
-       && derived->components->ts.u.derived->attr.unlimited_polymorphic)
+      && derived->components->ts.type == BT_DERIVED
+      && startswith (derived->name, "__class")
+      && strcmp (derived->components->name, "_data") == 0
+      && derived->components->ts.u.derived->attr.unlimited_polymorphic)
     unlimited_entity = true;
 
   /* Go through the derived type components, building them as
@@ -3067,11 +3076,24 @@ gfc_get_derived_type (gfc_symbol * derived, int codimen)
          if (c->attr.pointer || c->attr.allocatable || c->attr.pdt_array)
            {
              enum gfc_array_kind akind;
-             if (c->attr.pointer)
+             bool is_ptr = ((c == derived->components
+                             && derived->components->ts.type == BT_DERIVED
+                             && startswith (derived->name, "__class")
+                             && (strcmp (derived->components->name, "_data")
+                                 == 0))
+                            ? c->attr.class_pointer : c->attr.pointer);
+             if (is_ptr)
                akind = c->attr.contiguous ? GFC_ARRAY_POINTER_CONT
                                           : GFC_ARRAY_POINTER;
-             else
+             else if (c->attr.allocatable)
                akind = GFC_ARRAY_ALLOCATABLE;
+             else if (c->as->type == AS_ASSUMED_RANK)
+               akind = GFC_ARRAY_ASSUMED_RANK;
+             else
+               /* FIXME – see PR fortran/104651.  Additionally, the following
+                  gfc_build_array_type should use !is_ptr instead of
+                  c->attr.pointer and codim unconditionally without '? :'. */
+               akind = GFC_ARRAY_ASSUMED_SHAPE;
              /* Pointers to arrays aren't actually pointer types.  The
                 descriptors are separate, but the data is common.  Every
                 array pointer in a coarray derived type needs to provide space
@@ -3753,15 +3775,22 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
     t = fold_build_pointer_plus (t, data_off);
   t = build1 (NOP_EXPR, build_pointer_type (ptr_type_node), t);
   info->data_location = build1 (INDIRECT_REF, ptr_type_node, t);
-  if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ALLOCATABLE)
+  enum gfc_array_kind akind = GFC_TYPE_ARRAY_AKIND (type);
+  if (akind == GFC_ARRAY_ALLOCATABLE
+      || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE)
     info->allocated = build2 (NE_EXPR, logical_type_node,
                              info->data_location, null_pointer_node);
-  else if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER
-          || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_POINTER_CONT)
+  else if (akind == GFC_ARRAY_POINTER
+          || akind == GFC_ARRAY_POINTER_CONT
+          || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+          || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
     info->associated = build2 (NE_EXPR, logical_type_node,
                               info->data_location, null_pointer_node);
-  if ((GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK
-       || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_RANK_CONT)
+  if ((akind == GFC_ARRAY_ASSUMED_RANK
+       || akind == GFC_ARRAY_ASSUMED_RANK_CONT
+       || akind == GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE
+       || akind == GFC_ARRAY_ASSUMED_RANK_POINTER
+       || akind == GFC_ARRAY_ASSUMED_RANK_POINTER_CONT)
       && dwarf_version >= 5)
     {
       rank = 1;
@@ -3792,8 +3821,8 @@ gfc_get_array_descr_info (const_tree type, struct array_descr_info *info)
                                               dim_off, upper_suboff));
       t = build1 (INDIRECT_REF, gfc_array_index_type, t);
       info->dimen[dim].upper_bound = t;
-      if (GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE
-         || GFC_TYPE_ARRAY_AKIND (type) == GFC_ARRAY_ASSUMED_SHAPE_CONT)
+      if (akind == GFC_ARRAY_ASSUMED_SHAPE
+         || akind == GFC_ARRAY_ASSUMED_SHAPE_CONT)
        {
          /* Assumed shape arrays have known lower bounds.  */
          info->dimen[dim].upper_bound

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index e22e0f18f6fba5b8b9d043a8f2b01fe3f24c212e..69c3d90bb23b90b48c8db972d6cfeeb4bcb95503 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -1012,6 +1012,9 @@ enum gfc_array_kind
   GFC_ARRAY_ASSUMED_SHAPE_CONT,
   GFC_ARRAY_ASSUMED_RANK,
   GFC_ARRAY_ASSUMED_RANK_CONT,
+  GFC_ARRAY_ASSUMED_RANK_ALLOCATABLE,
+  GFC_ARRAY_ASSUMED_RANK_POINTER,
+  GFC_ARRAY_ASSUMED_RANK_POINTER_CONT,
   GFC_ARRAY_ALLOCATABLE,
   GFC_ARRAY_POINTER,
   GFC_ARRAY_POINTER_CONT