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
gcc/testsuite/ChangeLog: 2016-12-19 Andre Vehreschild <ve...@gcc.gnu.org> * gfortran.dg/class_assign_1.f08: New test. gcc/fortran/ChangeLog: 2016-12-19 Andre Vehreschild <ve...@gcc.gnu.org> * trans-expr.c (gfc_trans_assignment_1): Allocate memory of _vptr->size before assigning an allocatable class object.
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 +