]> gcc.gnu.org Git - gcc.git/commitdiff
Fortran: Fix class reallocate on assignment [PR99307].
authorPaul Thomas <pault@gcc.gnu.org>
Thu, 15 Apr 2021 06:34:26 +0000 (07:34 +0100)
committerPaul Thomas <pault@gcc.gnu.org>
Thu, 15 Apr 2021 06:34:26 +0000 (07:34 +0100)
2021-04-15  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
PR fortran/99307
* symbol.c: Remove trailing white space.
* trans-array.c (gfc_trans_create_temp_array): Create a class
temporary for class expressions and assign the new descriptor
to the data field.
(build_class_array_ref): If the class expr can be extracted,
then use that for 'decl'. Class function results are reliably
handled this way. Call gfc_find_and_cut_at_last_class_ref to
eliminate largely redundant code. Remove dead code and recast
the rest of the code to extract 'decl' for remaining cases.
Call gfc_build_spanned_array_ref.
(gfc_alloc_allocatable_for_assignment): Use class descriptor
element length for 'elemsize1'. Eliminate repeat set of dtype
for class expressions.
* trans-expr.c (gfc_find_and_cut_at_last_class_ref): Include
additional code from build_class_array_ref, and use optional
gfc_typespec pointer argument.
(gfc_trans_scalar_assign): Make use of pre and post blocks for
all class expressions.
* trans.c (get_array_span): For unlimited polymorphic exprs
multiply the span by the value of the _len field.
(gfc_build_spanned_array_ref): New function.
(gfc_build_array_ref): Call gfc_build_spanned_array_ref and
eliminate repeated code.
* trans.h: Add arg to gfc_find_and_cut_at_last_class_ref and
add prototype for gfc_build_spanned_array_ref.

gcc/fortran/symbol.c
gcc/fortran/trans-array.c
gcc/fortran/trans-expr.c
gcc/fortran/trans.c
gcc/fortran/trans.h

index e982374d9d12f65e383f8dafc9349e043ef35eb8..6d61bf4982bf4daf699d7ef56c19a102a6df2f1b 100644 (file)
@@ -4391,7 +4391,7 @@ get_iso_c_binding_dt (int sym_id)
          if (dt_list->from_intmod != INTMOD_NONE
              && dt_list->intmod_sym_id == sym_id)
            return dt_list;
-       
+
          dt_list = dt_list->dt_next;
        }
     }
index be5eb89350f46bb0ab719c7609650f4508cbdf5f..ca90142530c24ce0048270a11dcb0e800171387d 100644 (file)
@@ -1403,9 +1403,6 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
   desc = gfc_create_var (type, "atmp");
   GFC_DECL_PACKED_ARRAY (desc) = 1;
 
-  info->descriptor = desc;
-  size = gfc_index_one_node;
-
   /* Emit a DECL_EXPR for the variable sized array type in
      GFC_TYPE_ARRAY_DATAPTR_TYPE so the gimplification of its type
      sizes works correctly.  */
@@ -1416,9 +1413,40 @@ gfc_trans_create_temp_array (stmtblock_t * pre, stmtblock_t * post, gfc_ss * ss,
   gfc_add_expr_to_block (pre, build1 (DECL_EXPR,
                                      arraytype, TYPE_NAME (arraytype)));
 
-  /* Fill in the array dtype.  */
-  tmp = gfc_conv_descriptor_dtype (desc);
-  gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+  if (class_expr != NULL_TREE)
+    {
+      tree class_data;
+      tree dtype;
+
+      /* Create a class temporary.  */
+      tmp = gfc_create_var (TREE_TYPE (class_expr), "ctmp");
+      gfc_add_modify (pre, tmp, class_expr);
+
+      /* Assign the new descriptor to the _data field. This allows the
+        vptr _copy to be used for scalarized assignment since the class
+        temporary can be found from the descriptor.  */
+      class_data = gfc_class_data_get (tmp);
+      tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+                            TREE_TYPE (desc), desc);
+      gfc_add_modify (pre, class_data, tmp);
+
+      /* Take the dtype from the class expression.  */
+      dtype = gfc_conv_descriptor_dtype (gfc_class_data_get (class_expr));
+      tmp = gfc_conv_descriptor_dtype (class_data);
+      gfc_add_modify (pre, tmp, dtype);
+
+      /* Point desc to the class _data field.  */
+      desc = class_data;
+    }
+  else
+    {
+      /* Fill in the array dtype.  */
+      tmp = gfc_conv_descriptor_dtype (desc);
+      gfc_add_modify (pre, tmp, gfc_get_dtype (TREE_TYPE (desc)));
+    }
+
+  info->descriptor = desc;
+  size = gfc_index_one_node;
 
   /*
      Fill in the bounds and stride.  This is a packed array, so:
@@ -3424,134 +3452,73 @@ conv_array_index_offset (gfc_se * se, gfc_ss * ss, int dim, int i,
 static bool
 build_class_array_ref (gfc_se *se, tree base, tree index)
 {
-  tree type;
   tree size;
-  tree offset;
   tree decl = NULL_TREE;
   tree tmp;
   gfc_expr *expr = se->ss->info->expr;
-  gfc_ref *ref;
-  gfc_ref *class_ref = NULL;
+  gfc_expr *class_expr;
   gfc_typespec *ts;
+  gfc_symbol *sym;
 
-  if (se->expr && DECL_P (se->expr) && DECL_LANG_SPECIFIC (se->expr)
-      && GFC_DECL_SAVED_DESCRIPTOR (se->expr)
-      && GFC_CLASS_TYPE_P (TREE_TYPE (GFC_DECL_SAVED_DESCRIPTOR (se->expr))))
-    decl = se->expr;
+  tmp = !VAR_P (base) ? gfc_get_class_from_expr (base) : NULL_TREE;
+
+  if (tmp != NULL_TREE)
+    decl = tmp;
   else
     {
-      if (expr == NULL
+      /* The base expression does not contain a class component, either
+        because it is a temporary array or array descriptor.  Class
+        array functions are correctly resolved above.  */
+      if (!expr
          || (expr->ts.type != BT_CLASS
-             && !gfc_is_class_array_function (expr)
              && !gfc_is_class_array_ref (expr, NULL)))
        return false;
 
-      if (expr->symtree && expr->symtree->n.sym->ts.type == BT_CLASS)
-       ts = &expr->symtree->n.sym->ts;
-      else
-       ts = NULL;
-
-      for (ref = expr->ref; ref; ref = ref->next)
-       {
-         if (ref->type == REF_COMPONENT
-             && ref->u.c.component->ts.type == BT_CLASS
-             && ref->next && ref->next->type == REF_COMPONENT
-             && strcmp (ref->next->u.c.component->name, "_data") == 0
-             && ref->next->next
-             && ref->next->next->type == REF_ARRAY
-             && ref->next->next->u.ar.type != AR_ELEMENT)
-           {
-             ts = &ref->u.c.component->ts;
-             class_ref = ref;
-             break;
-           }
-       }
+      /* Obtain the expression for the class entity or component that is
+        followed by an array reference, which is not an element, so that
+        the span of the array can be obtained.  */
+      class_expr = gfc_find_and_cut_at_last_class_ref (expr, false, &ts);
 
-      if (ts == NULL)
+      if (!ts)
        return false;
-    }
 
-  if (class_ref == NULL && expr && expr->symtree->n.sym->attr.function
-      && expr->symtree->n.sym == expr->symtree->n.sym->result
-      && expr->symtree->n.sym->backend_decl == current_function_decl)
-    {
-      decl = gfc_get_fake_result_decl (expr->symtree->n.sym, 0);
-    }
-  else if (expr && gfc_is_class_array_function (expr))
-    {
-      size = NULL_TREE;
-      decl = NULL_TREE;
-      for (tmp = base; tmp; tmp = TREE_OPERAND (tmp, 0))
-       {
-         tree type;
-         type = TREE_TYPE (tmp);
-         while (type)
-           {
-             if (GFC_CLASS_TYPE_P (type))
-               decl = tmp;
-             if (type != TYPE_CANONICAL (type))
-               type = TYPE_CANONICAL (type);
-             else
-               type = NULL_TREE;
-           }
-         if (VAR_P (tmp))
-           break;
+      sym = (!class_expr && expr) ? expr->symtree->n.sym : NULL;
+      if (sym && sym->attr.function
+         && sym == sym->result
+         && sym->backend_decl == current_function_decl)
+       /* The temporary is the data field of the class data component
+          of the current function.  */
+       decl = gfc_get_fake_result_decl (sym, 0);
+      else if (sym)
+       {
+         if (decl == NULL_TREE)
+           decl = expr->symtree->n.sym->backend_decl;
+         /* For class arrays the tree containing the class is stored in
+            GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
+            For all others it's sym's backend_decl directly.  */
+         if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
+           decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
        }
+      else
+       decl = gfc_get_class_from_gfc_expr (class_expr);
 
-      if (decl == NULL_TREE)
-       return false;
+      if (POINTER_TYPE_P (TREE_TYPE (decl)))
+       decl = build_fold_indirect_ref_loc (input_location, decl);
 
-      se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
-    }
-  else if (class_ref == NULL)
-    {
-      if (decl == NULL_TREE)
-       decl = expr->symtree->n.sym->backend_decl;
-      /* For class arrays the tree containing the class is stored in
-        GFC_DECL_SAVED_DESCRIPTOR of the sym's backend_decl.
-        For all others it's sym's backend_decl directly.  */
-      if (DECL_LANG_SPECIFIC (decl) && GFC_DECL_SAVED_DESCRIPTOR (decl))
-       decl = GFC_DECL_SAVED_DESCRIPTOR (decl);
-    }
-  else
-    {
-      /* Remove everything after the last class reference, convert the
-        expression and then recover its tailend once more.  */
-      gfc_se tmpse;
-      ref = class_ref->next;
-      class_ref->next = NULL;
-      gfc_init_se (&tmpse, NULL);
-      gfc_conv_expr (&tmpse, expr);
-      gfc_add_block_to_block (&se->pre, &tmpse.pre);
-      decl = tmpse.expr;
-      class_ref->next = ref;
+      if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
+       return false;
     }
 
-  if (POINTER_TYPE_P (TREE_TYPE (decl)))
-    decl = build_fold_indirect_ref_loc (input_location, decl);
-
-  if (!GFC_CLASS_TYPE_P (TREE_TYPE (decl)))
-    return false;
+  se->class_vptr = gfc_evaluate_now (gfc_class_vptr_get (decl), &se->pre);
 
   size = gfc_class_vtab_size_get (decl);
-
   /* For unlimited polymorphic entities then _len component needs to be
      multiplied with the size.  */
   size = gfc_resize_class_size_with_len (&se->pre, decl, size);
-
   size = fold_convert (TREE_TYPE (index), size);
 
-  /* Build the address of the element.  */
-  type = TREE_TYPE (TREE_TYPE (base));
-  offset = fold_build2_loc (input_location, MULT_EXPR,
-                           gfc_array_index_type,
-                           index, size);
-  tmp = gfc_build_addr_expr (pvoid_type_node, base);
-  tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
-  tmp = fold_convert (build_pointer_type (type), tmp);
-
   /* Return the element in the se expression.  */
-  se->expr = build_fold_indirect_ref_loc (input_location, tmp);
+  se->expr = gfc_build_spanned_array_ref (base, index, size);
   return true;
 }
 
@@ -10280,23 +10247,10 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
     }
   else if (expr1->ts.type == BT_CLASS)
     {
-      tmp = expr1->rank ? gfc_get_class_from_expr (desc) : NULL_TREE;
-      if (tmp == NULL_TREE)
-       tmp = gfc_get_class_from_gfc_expr (expr1);
-
-      if (tmp != NULL_TREE)
-       {
-         tmp2 = gfc_class_vptr_get (tmp);
-         cond = fold_build2_loc (input_location, NE_EXPR,
-                                 logical_type_node, tmp2,
-                                 build_int_cst (TREE_TYPE (tmp2), 0));
-         elemsize1 = gfc_class_vtab_size_get (tmp);
-         elemsize1 = fold_build3_loc (input_location, COND_EXPR,
-                                     gfc_array_index_type, cond,
-                                     elemsize1, gfc_index_zero_node);
-       }
-      else
-       elemsize1 = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&CLASS_DATA (expr1)->ts));
+      /* Unfortunately, the lhs vptr is set too early in many cases.
+        Play it safe by using the descriptor element length.  */
+      tmp = gfc_conv_descriptor_elem_len (desc);
+      elemsize1 = fold_convert (gfc_array_index_type, tmp);
     }
   else
     elemsize1 = NULL_TREE;
@@ -10770,11 +10724,11 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
 
 
   /* We already set the dtype in the case of deferred character
-     length arrays and unlimited polymorphic arrays.  */
+     length arrays and class lvalues.  */
   if (!(GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (desc))
        && ((expr1->ts.type == BT_CHARACTER && expr1->ts.deferred)
            || coarray))
-      && !UNLIMITED_POLY (expr1))
+      && expr1->ts.type != BT_CLASS)
     {
       tmp = gfc_conv_descriptor_dtype (desc);
       gfc_add_modify (&alloc_block, tmp, gfc_get_dtype (TREE_TYPE (desc)));
index 2fa17b36c03a9fdba709c276068ad6b14f6918a8..213f32b0a672f99c339de98fa7507cf27aacdc95 100644 (file)
@@ -380,15 +380,20 @@ gfc_vptr_size_get (tree vptr)
 #undef VTABLE_FINAL_FIELD
 
 
-/* Search for the last _class ref in the chain of references of this
-   expression and cut the chain there.  Albeit this routine is similiar
-   to class.c::gfc_add_component_ref (), is there a significant
-   difference: gfc_add_component_ref () concentrates on an array ref to
-   be the last ref in the chain.  This routine is oblivious to the kind
-   of refs following.  */
+/* IF ts is null (default), search for the last _class ref in the chain
+   of references of the expression and cut the chain there.  Although
+   this routine is similiar to class.c:gfc_add_component_ref (), there
+   is a significant difference: gfc_add_component_ref () concentrates
+   on an array ref that is the last ref in the chain and is oblivious
+   to the kind of refs following.
+   ELSE IF ts is non-null the cut is at the class entity or component
+   that is followed by an array reference, which is not an element.
+   These calls come from trans-array.c:build_class_array_ref, which
+   handles scalarized class array references.*/
 
 gfc_expr *
-gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold)
+gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold,
+                                   gfc_typespec **ts)
 {
   gfc_expr *base_expr;
   gfc_ref *ref, *class_ref, *tail = NULL, *array_ref;
@@ -396,27 +401,59 @@ gfc_find_and_cut_at_last_class_ref (gfc_expr *e, bool is_mold)
   /* Find the last class reference.  */
   class_ref = NULL;
   array_ref = NULL;
-  for (ref = e->ref; ref; ref = ref->next)
+
+  if (ts)
     {
-      if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
-       array_ref = ref;
+      if (e->symtree
+         && e->symtree->n.sym->ts.type == BT_CLASS)
+       *ts = &e->symtree->n.sym->ts;
+      else
+       *ts = NULL;
+    }
 
-      if (ref->type == REF_COMPONENT
-         && ref->u.c.component->ts.type == BT_CLASS)
+  for (ref = e->ref; ref; ref = ref->next)
+    {
+      if (ts)
        {
-         /* Component to the right of a part reference with nonzero rank
-            must not have the ALLOCATABLE attribute.  If attempts are
-            made to reference such a component reference, an error results
-            followed by an ICE.  */
-         if (array_ref && CLASS_DATA (ref->u.c.component)->attr.allocatable)
-           return NULL;
-         class_ref = ref;
+         if (ref->type == REF_COMPONENT
+             && ref->u.c.component->ts.type == BT_CLASS
+             && ref->next && ref->next->type == REF_COMPONENT
+             && !strcmp (ref->next->u.c.component->name, "_data")
+             && ref->next->next
+             && ref->next->next->type == REF_ARRAY
+             && ref->next->next->u.ar.type != AR_ELEMENT)
+           {
+             *ts = &ref->u.c.component->ts;
+             class_ref = ref;
+             break;
+           }
+
+         if (ref->next == NULL)
+           break;
        }
+      else
+       {
+         if (ref->type == REF_ARRAY && ref->u.ar.type != AR_ELEMENT)
+           array_ref = ref;
 
-      if (ref->next == NULL)
-       break;
+         if (ref->type == REF_COMPONENT
+             && ref->u.c.component->ts.type == BT_CLASS)
+           {
+             /* Component to the right of a part reference with nonzero
+                rank must not have the ALLOCATABLE attribute.  If attempts
+                are made to reference such a component reference, an error
+                results followed by an ICE.  */
+             if (array_ref
+                 && CLASS_DATA (ref->u.c.component)->attr.allocatable)
+               return NULL;
+             class_ref = ref;
+           }
+       }
     }
 
+  if (ts && *ts == NULL)
+    return NULL;
+
   /* Remove and store all subsequent references after the
      CLASS reference.  */
   if (class_ref)
@@ -10005,17 +10042,20 @@ gfc_trans_scalar_assign (gfc_se * lse, gfc_se * rse, gfc_typespec ts,
       gfc_add_modify (&block, lse->expr, tmp);
     }
   /* If possible use the rhs vptr copy with trans_scalar_class_assign....  */
-  else if (ts.type == BT_CLASS
-          && !trans_scalar_class_assign (&block, lse, rse))
+  else if (ts.type == BT_CLASS)
     {
       gfc_add_block_to_block (&block, &lse->pre);
       gfc_add_block_to_block (&block, &rse->pre);
-      /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
-        for the lhs which ensures that class data rhs cast as a string assigns
-        correctly.  */
-      tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
-                            TREE_TYPE (rse->expr), lse->expr);
-      gfc_add_modify (&block, tmp, rse->expr);
+
+      if (!trans_scalar_class_assign (&block, lse, rse))
+       {
+         /* ...otherwise assignment suffices. Note the use of VIEW_CONVERT_EXPR
+         for the lhs which ensures that class data rhs cast as a string assigns
+         correctly.  */
+         tmp = fold_build1_loc (input_location, VIEW_CONVERT_EXPR,
+                                TREE_TYPE (rse->expr), lse->expr);
+         gfc_add_modify (&block, tmp, rse->expr);
+       }
     }
   else if (ts.type != BT_CLASS)
     {
index ab53fc5f441d7ccbb53649ee81d7d3fb05797f97..9e8e8619ff837ba18dfd9374794db0eb9b0d380b 100644 (file)
@@ -422,6 +422,9 @@ get_array_span (tree type, tree decl)
                return NULL_TREE;
            }
          span = gfc_class_vtab_size_get (decl);
+         /* For unlimited polymorphic entities then _len component needs
+            to be multiplied with the size.  */
+         span = gfc_resize_class_size_with_len (NULL, decl, span);
        }
       else if (GFC_DECL_PTR_ARRAY_P (decl))
        {
@@ -439,13 +442,31 @@ get_array_span (tree type, tree decl)
 }
 
 
+tree
+gfc_build_spanned_array_ref (tree base, tree offset, tree span)
+{
+  tree type;
+  tree tmp;
+  type = TREE_TYPE (TREE_TYPE (base));
+  offset = fold_build2_loc (input_location, MULT_EXPR,
+                           gfc_array_index_type,
+                           offset, span);
+  tmp = gfc_build_addr_expr (pvoid_type_node, base);
+  tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
+  tmp = fold_convert (build_pointer_type (type), tmp);
+  if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE)
+      || !TYPE_STRING_FLAG (type))
+    tmp = build_fold_indirect_ref_loc (input_location, tmp);
+  return tmp;
+}
+
+
 /* Build an ARRAY_REF with its natural type.  */
 
 tree
 gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
 {
   tree type = TREE_TYPE (base);
-  tree tmp;
   tree span = NULL_TREE;
 
   if (GFC_ARRAY_TYPE_P (type) && GFC_TYPE_ARRAY_RANK (type) == 0)
@@ -488,18 +509,7 @@ gfc_build_array_ref (tree base, tree offset, tree decl, tree vptr)
   /* If a non-null span has been generated reference the element with
      pointer arithmetic.  */
   if (span != NULL_TREE)
-    {
-      offset = fold_build2_loc (input_location, MULT_EXPR,
-                               gfc_array_index_type,
-                               offset, span);
-      tmp = gfc_build_addr_expr (pvoid_type_node, base);
-      tmp = fold_build_pointer_plus_loc (input_location, tmp, offset);
-      tmp = fold_convert (build_pointer_type (type), tmp);
-      if ((TREE_CODE (type) != INTEGER_TYPE && TREE_CODE (type) != ARRAY_TYPE)
-         || !TYPE_STRING_FLAG (type))
-       tmp = build_fold_indirect_ref_loc (input_location, tmp);
-      return tmp;
-    }
+    return gfc_build_spanned_array_ref (base, offset, span);
   /* Otherwise use a straightforward array reference.  */
   else
     return build4_loc (input_location, ARRAY_REF, type, base, offset,
index 44cbfb63f39246e0f145308a82a5b14475548f33..8c6f82ff1b121d51b04b1a0e26fb2c708562838c 100644 (file)
@@ -424,7 +424,8 @@ tree gfc_class_vptr_get (tree);
 tree gfc_class_len_get (tree);
 tree gfc_class_len_or_zero_get (tree);
 tree gfc_resize_class_size_with_len (stmtblock_t *, tree, tree);
-gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false);
+gfc_expr * gfc_find_and_cut_at_last_class_ref (gfc_expr *, bool is_mold = false,
+                                              gfc_typespec **ts = NULL);
 /* Get an accessor to the class' vtab's * field, when a class handle is
    available.  */
 tree gfc_class_vtab_hash_get (tree);
@@ -622,6 +623,9 @@ tree gfc_build_addr_expr (tree, tree);
 /* Build an ARRAY_REF.  */
 tree gfc_build_array_ref (tree, tree, tree, tree vptr = NULL_TREE);
 
+/* Build an array ref using pointer arithmetic.  */
+tree gfc_build_spanned_array_ref (tree base, tree offset, tree span);
+
 /* Creates a label.  Decl is artificial if label_id == NULL_TREE.  */
 tree gfc_build_label_decl (tree);
 
This page took 0.092923 seconds and 5 git commands to generate.