Fix failures with -m32 and some memory leaks.

2020-12-23  Paul Thomas  <pault@gcc.gnu.org>

gcc/fortran
	PR fortran/83118
	* trans-array.c (gfc_alloc_allocatable_for_assignment): Make
	sure that class expressions are captured for dummy arguments by
	use of gfc_get_class_from_gfc_expr otherwise the wrong vptr is
	used.
	* trans-expr.c (gfc_get_class_from_gfc_expr): New function.
	(gfc_get_class_from_expr): If a constant expression is
	encountered, return NULL_TREE;
	(gfc_trans_assignment_1): Deallocate rhs allocatable components
	after passing derived type function results to class lhs.
	* trans.h : Add prototype for gfc_get_class_from_gfc_expr.

diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c
index 9e461f94536272aa5a6a274e4b5221e9cb7567aa..2c6be710ac8be70d9e7fe94961e22cb216ecc600 100644 (file)
--- a/gcc/fortran/trans-array.c
+++ b/gcc/fortran/trans-array.c
@@ -10176,6 +10176,7 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   tree jump_label2;
   tree neq_size;
   tree lbd;
+  tree class_expr2 = NULL_TREE;
   int n;
   int dim;
   gfc_array_spec * as;
@@ -10257,6 +10258,9 @@ 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);
@@ -10332,6 +10336,9 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
   else if (expr1->ts.type == BT_CLASS && expr2->ts.type == BT_CLASS)
     {
       tmp = expr2->rank ? gfc_get_class_from_expr (desc2) : NULL_TREE;
+      if (tmp == NULL_TREE && expr2->expr_type == EXPR_VARIABLE)
+       tmp = class_expr2 = gfc_get_class_from_gfc_expr (expr2);
+
       if (tmp != NULL_TREE)
        tmp = gfc_class_vtab_size_get (tmp);
       else
@@ -10617,6 +10624,8 @@ gfc_alloc_allocatable_for_assignment (gfc_loopinfo *loop,
          tmp2 = gfc_get_class_from_expr (desc2);
          tmp2 = gfc_class_vptr_get (tmp2);
        }
+      else if (expr2->ts.type == BT_CLASS && class_expr2 != NULL_TREE)
+       tmp2 = gfc_class_vptr_get (class_expr2);
       else
        {
          tmp2 = gfc_get_symbol_decl (gfc_find_vtab (&expr2->ts));

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index f66afab85d11b5c3c5af1de467e35314de2e37f6..14361a10f6832d89332f9ef3de6c5882df4ca29f 100644 (file)
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -508,6 +508,25 @@ gfc_reset_len (stmtblock_t *block, gfc_expr *expr)
 }
 
 
+/* Obtain the last class reference in a gfc_expr. Return NULL_TREE if no class
+   reference is found. Note that it is up to the caller to avoid using this
+   for expressions other than variables.  */
+
+tree
+gfc_get_class_from_gfc_expr (gfc_expr *e)
+{
+  gfc_expr *class_expr;
+  gfc_se cse;
+  class_expr = gfc_find_and_cut_at_last_class_ref (e);
+  if (class_expr == NULL)
+    return NULL_TREE;
+  gfc_init_se (&cse, NULL);
+  gfc_conv_expr (&cse, class_expr);
+  gfc_free_expr (class_expr);
+  return cse.expr;
+}
+
+
 /* Obtain the last class reference in an expression.
    Return NULL_TREE if no class reference is found.  */
 
@@ -11297,11 +11316,24 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   tmp = NULL_TREE;
 
   if (is_poly_assign)
-    tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
-                                 use_vptr_copy || (lhs_attr.allocatable
-                                                    && !lhs_attr.dimension),
-                                 !realloc_flag && flag_realloc_lhs
-                                 && !lhs_attr.pointer);
+    {
+      tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse,
+                                   use_vptr_copy || (lhs_attr.allocatable
+                                                     && !lhs_attr.dimension),
+                                   !realloc_flag && flag_realloc_lhs
+                                   && !lhs_attr.pointer);
+      if (expr2->expr_type == EXPR_FUNCTION
+         && expr2->ts.type == BT_DERIVED
+         && expr2->ts.u.derived->attr.alloc_comp)
+       {
+         tree tmp2 = gfc_deallocate_alloc_comp (expr2->ts.u.derived,
+                                                rse.expr, expr2->rank);
+         if (lss == gfc_ss_terminator)
+           gfc_add_expr_to_block (&rse.post, tmp2);
+         else
+           gfc_add_expr_to_block (&loop.post, tmp2);
+       }
+    }
   else if (flag_coarray == GFC_FCOARRAY_LIB
           && lhs_caf_attr.codimension && rhs_caf_attr.codimension
           && ((lhs_caf_attr.allocatable && lhs_refs_comp)

diff --git a/gcc/fortran/trans.h b/gcc/fortran/trans.h
index a1613bd02f3f7a0495a7bebd87a2657b04508c4e..9ef9b964e10bfdfa85884a5ecd845055eba7626f 100644 (file)
--- a/gcc/fortran/trans.h
+++ b/gcc/fortran/trans.h
@@ -443,6 +443,7 @@ tree gfc_vptr_final_get (tree);
 tree gfc_vptr_deallocate_get (tree);
 void gfc_reset_vptr (stmtblock_t *, gfc_expr *);
 void gfc_reset_len (stmtblock_t *, gfc_expr *);
+tree gfc_get_class_from_gfc_expr (gfc_expr *);
 tree gfc_get_class_from_expr (tree);
 tree gfc_get_vptr_from_expr (tree);
 tree gfc_get_class_array_ref (tree, tree, tree, bool);