@@ -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);
new file mode 100644
@@ -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
+