[PATCH, Fortran, alloc_poly, v1] Fix allocation of memory for polymorphic assignment

[Andre Vehreschild <vehre at gmx dot de>]

Hi all,

attached is a patch to fix the incorrect computation of memory needed in a
polymorphic assignment. Formerly the memory required could not be determined
and therefore one byte was allocated. This is fixed now, by retrieving the
size needed from the _vptr->size.

Bootstraps and regtests ok on x86_64-linux/f23. Ok for trunk?

Regards,
	Andre
-- 
Andre Vehreschild * Email: vehre ad gmx dot de

Attachment: alloc_poly_v1.clog
Description: Text document

diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c
index 823c96a..5f84680 100644
--- a/gcc/fortran/trans-expr.c
+++ b/gcc/fortran/trans-expr.c
@@ -9968,7 +9968,27 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
       /* Modify the expr1 after the assignment, to allow the realloc below.
 	 Therefore only needed, when realloc_lhs is enabled.  */
       if (flag_realloc_lhs && !lhs_attr.pointer)
-	gfc_add_data_component (expr1);
+	{
+	  stmtblock_t alloc;
+	  tree tem, class_han = gfc_class_data_get (lse.expr);
+	  if (GFC_CLASS_TYPE_P (TREE_TYPE (rse.expr)))
+	    tem = gfc_class_vtab_size_get (rse.expr);
+	  else
+	    tem = gfc_vptr_size_get (
+		  gfc_build_addr_expr (NULL_TREE,
+				     gfc_find_vtab (&expr2->ts)->backend_decl));
+	  gfc_init_block (&alloc);
+	  gfc_allocate_using_malloc (&alloc, class_han, tem, NULL_TREE);
+	  tem = fold_build2_loc (input_location, EQ_EXPR,
+				 boolean_type_node, class_han,
+				 build_int_cst (prvoid_type_node, 0));
+	  tem = fold_build3_loc (input_location, COND_EXPR, void_type_node,
+				 gfc_unlikely (tem,
+					       PRED_FORTRAN_FAIL_ALLOC),
+				 gfc_finish_block (&alloc),
+				 build_empty_stmt (input_location));
+	  gfc_add_expr_to_block (&lse.pre, tem);
+	}
     }
   else if (flag_coarray == GFC_FCOARRAY_LIB
 	   && lhs_caf_attr.codimension && rhs_caf_attr.codimension
@@ -10011,7 +10031,8 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag,
   if (lss == gfc_ss_terminator)
     {
       /* F2003: Add the code for reallocation on assignment.  */
-      if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1))
+      if (flag_realloc_lhs && is_scalar_reallocatable_lhs (expr1)
+	  && !is_poly_assign)
 	alloc_scalar_allocatable_for_assignment (&block, string_length,
 						 expr1, expr2);
 
diff --git a/gcc/testsuite/gfortran.dg/class_assign_1.f08 b/gcc/testsuite/gfortran.dg/class_assign_1.f08
new file mode 100644
index 0000000..fb1f655
--- /dev/null
+++ b/gcc/testsuite/gfortran.dg/class_assign_1.f08
@@ -0,0 +1,71 @@
+! { dg-do run }
+!
+! Check that reallocation of the lhs is done with the correct memory size.
+
+
+module base_mod
+
+  type, abstract :: base
+  contains
+    procedure(base_add), deferred :: add
+    generic :: operator(+) => add
+  end type base
+
+  abstract interface
+    module function base_add(l, r) result(res)
+      class(base), intent(in) :: l
+      integer, intent(in) :: r
+      class(base), allocatable :: res
+    end function base_add
+  end interface
+
+contains
+
+  subroutine foo(x)
+    class(base), intent(inout), allocatable :: x
+    class(base), allocatable :: t
+
+    t = x + 2
+    x = t + 40
+  end subroutine foo
+
+end module base_mod
+
+module extend_mod
+  use base_mod
+
+  type, extends(base) :: extend
+    integer :: i
+  contains
+    procedure :: add
+  end type extend
+
+contains
+  module function add(l, r) result(res)
+    class(extend), intent(in) :: l
+    integer, intent(in) :: r
+    class(base), allocatable :: res
+    select type (l)
+      class is (extend)
+        res = extend(l%i + r)
+      class default
+        error stop "Unkown class to add to."
+    end select
+  end function
+end module extend_mod
+
+program test_poly_ass
+  use extend_mod
+  use base_mod
+
+  class(base), allocatable :: obj
+  obj = extend(0)
+  call foo(obj)
+  select type (obj)
+    class is (extend)
+      if (obj%i /= 42) error stop
+    class default
+      error stop "Result's type wrong."
+  end select
+end program test_poly_ass
+