From: Paul Thomas <pault@gcc.gnu.org>
Date: Sat, 26 Dec 2020 15:08:11 +0000 (+0000)
Subject: Fix failures with -m32 and some memory leaks.
X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=0175d45d14b1f9ebc4c15ea5bafcda655c37fc35;p=gcc.git

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 9e461f94536..2c6be710ac8 100644
--- 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 f66afab85d1..14361a10f68 100644
--- 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 a1613bd02f3..9ef9b964e10 100644
--- 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);