re PR fortran/78990 (ICE when assigning polymorphic array function result)

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

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index c5e1d72bd04bd2c14c29b413a9cd2fddc40ab939..92d37ec090199c90246ff044a5e658de3dda870e 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -960,6 +960,7 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
     }
 
   if ((ref == NULL || class_ref == ref)
+      && !(gfc_is_class_array_function (e) && parmse->class_vptr != NULL_TREE)
       && (!class_ts.u.derived->components->as
          || class_ts.u.derived->components->as->rank != -1))
     return;
@@ -1030,8 +1031,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
      First we have to find the corresponding class reference.  */
 
   tmp = NULL_TREE;
-  if (class_ref == NULL
-       && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
+  if (gfc_is_class_array_function (e)
+      && parmse->class_vptr != NULL_TREE)
+    tmp = parmse->class_vptr;
+  else if (class_ref == NULL
+          && e->symtree && e->symtree->n.sym->ts.type == BT_CLASS)
     {
       tmp = e->symtree->n.sym->backend_decl;
 
@@ -1063,7 +1067,11 @@ gfc_conv_class_to_class (gfc_se *parmse, gfc_expr *e, gfc_typespec class_ts,
   if (TREE_CODE (TREE_TYPE (tmp)) == REFERENCE_TYPE)
     tmp = build_fold_indirect_ref_loc (input_location, tmp);
 
-  vptr = gfc_class_vptr_get (tmp);
+  if (!(gfc_is_class_array_function (e) && parmse->class_vptr))
+    vptr = gfc_class_vptr_get (tmp);
+  else
+    vptr = tmp;
+
   gfc_add_modify (&block, ctree,
                  fold_convert (TREE_TYPE (ctree), vptr));
 
@@ -4435,7 +4443,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
   /* Reset the offset for the function call since the loop
      is zero based on the data pointer.  Note that the temp
      comes first in the loop chain since it is added second.  */
-  if (gfc_is_alloc_class_array_function (expr))
+  if (gfc_is_class_array_function (expr))
     {
       tmp = loop.ss->loop_chain->info->data.array.descriptor;
       gfc_conv_descriptor_offset_set (&loop.pre, tmp,
@@ -4484,7 +4492,7 @@ gfc_conv_subref_array_arg (gfc_se * parmse, gfc_expr * expr, int g77,
   dimen = rse.ss->dimen;
 
   /* Skip the write-out loop for this case.  */
-  if (gfc_is_alloc_class_array_function (expr))
+  if (gfc_is_class_array_function (expr))
     goto class_array_fcn;
 
   /* Calculate the bounds of the scalarization.  */
@@ -4778,7 +4786,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
              gcc_assert ((!comp && gfc_return_by_reference (sym)
                           && sym->result->attr.dimension)
                          || (comp && comp->attr.dimension)
-                         || gfc_is_alloc_class_array_function (expr));
+                         || gfc_is_class_array_function (expr));
              gcc_assert (se->loop != NULL);
              /* Access the previously obtained result.  */
              gfc_conv_tmp_array_ref (se);
@@ -5462,7 +5470,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                                fsym ? fsym->attr.intent : INTENT_INOUT,
                                fsym && fsym->attr.pointer);
 
-             else if (gfc_is_alloc_class_array_function (e)
+             else if (gfc_is_class_array_function (e)
                         && fsym && fsym->ts.type == BT_DERIVED)
                /* See previous comment.  For function actual argument,
                   the write out is not needed so the intent is set as
@@ -6304,7 +6312,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
         call the finalization function of the temporary. Note that the
         nullification of allocatable components needed by the result
         is done in gfc_trans_assignment_1.  */
-      if (expr && ((gfc_is_alloc_class_array_function (expr)
+      if (expr && ((gfc_is_class_array_function (expr)
                    && se->ss && se->ss->loop)
                   || gfc_is_alloc_class_scalar_function (expr))
          && se->expr && GFC_CLASS_TYPE_P (TREE_TYPE (se->expr))
@@ -6315,6 +6323,7 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
          int n;
          if (se->ss && se->ss->loop)
            {
+             gfc_add_block_to_block (&se->ss->loop->pre, &se->pre);
              se->expr = gfc_evaluate_now (se->expr, &se->ss->loop->pre);
              tmp = gfc_class_data_get (se->expr);
              info->descriptor = tmp;
@@ -6337,6 +6346,11 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
                        CLASS_DATA (expr->value.function.esym->result)->attr);
            }
 
+         if ((gfc_is_class_array_function (expr)
+              || gfc_is_alloc_class_scalar_function (expr))
+             && CLASS_DATA (expr->value.function.esym->result)->attr.pointer)
+           goto no_finalization;
+
          final_fndecl = gfc_class_vtab_final_get (se->expr);
          is_final = fold_build2_loc (input_location, NE_EXPR,
                                      logical_type_node,
@@ -6367,6 +6381,8 @@ gfc_conv_procedure_call (gfc_se * se, gfc_symbol * sym,
              tmp = gfc_call_free (tmp);
              gfc_add_expr_to_block (&se->post, tmp);
            }
+
+no_finalization:
          expr->must_finalize = 0;
        }
 
@@ -8887,7 +8903,7 @@ arrayfunc_assign_needs_temporary (gfc_expr * expr1, gfc_expr * expr2)
   gfc_symbol *sym = expr1->symtree->n.sym;
 
   /* Play it safe with class functions assigned to a derived type.  */
-  if (gfc_is_alloc_class_array_function (expr2)
+  if (gfc_is_class_array_function (expr2)
       && expr1->ts.type == BT_DERIVED)
     return true;
 
@@ -9894,7 +9910,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   rss = NULL;
 
   if ((expr1->ts.type == BT_DERIVED)
-      && (gfc_is_alloc_class_array_function (expr2)
+      && (gfc_is_class_array_function (expr2)
          || gfc_is_alloc_class_scalar_function (expr2)))
     expr2->must_finalize = 1;
 
@@ -10101,7 +10117,7 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
      a scalar to array assignment, this is done in gfc_trans_scalar_assign
      as part of the deep copy.  */
   if (!scalar_to_array && expr1->ts.type == BT_DERIVED
-                      && (gfc_is_alloc_class_array_function (expr2)
+                      && (gfc_is_class_array_function (expr2)
                           || gfc_is_alloc_class_scalar_function (expr2)))
     {
       tmp = rse.expr;