diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/fortran/ChangeLog | 7 | ||||
| -rw-r--r-- | gcc/fortran/trans-expr.c | 49 | ||||
| -rw-r--r-- | gcc/testsuite/ChangeLog | 4 | ||||
| -rw-r--r-- | gcc/testsuite/gfortran.dg/class_assign_1.f08 | 71 |
4 files changed, 115 insertions, 16 deletions
diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index ea284f4..f34ec9a 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,10 @@ +2016-12-23 Andre Vehreschild <vehre@gcc.gnu.org> + + * trans-expr.c (trans_class_assignment): Allocate memory of _vptr->size + before assigning an allocatable class object. + (gfc_trans_assignment_1): Flag that (re-)alloc of the class object + shall be done. + 2016-12-21 Jakub Jelinek <jakub@redhat.com> PR fortran/78866 diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 6ebdc8b..00fddfe 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -9625,17 +9625,38 @@ is_runtime_conformable (gfc_expr *expr1, gfc_expr *expr2) static tree trans_class_assignment (stmtblock_t *block, gfc_expr *lhs, gfc_expr *rhs, - gfc_se *lse, gfc_se *rse, bool use_vptr_copy) + gfc_se *lse, gfc_se *rse, bool use_vptr_copy, + bool class_realloc) { - tree tmp; - tree fcn; - tree stdcopy, to_len, from_len; + tree tmp, fcn, stdcopy, to_len, from_len, vptr; vec<tree, va_gc> *args = NULL; - tmp = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len, + vptr = trans_class_vptr_len_assignment (block, lhs, rhs, rse, &to_len, &from_len); - fcn = gfc_vptr_copy_get (tmp); + /* Generate allocation of the lhs. */ + if (class_realloc) + { + stmtblock_t alloc; + tree class_han; + + tmp = gfc_vptr_size_get (vptr); + class_han = GFC_CLASS_TYPE_P (TREE_TYPE (lse->expr)) + ? gfc_class_data_get (lse->expr) : lse->expr; + gfc_init_block (&alloc); + gfc_allocate_using_malloc (&alloc, class_han, tmp, NULL_TREE); + tmp = fold_build2_loc (input_location, EQ_EXPR, + boolean_type_node, class_han, + build_int_cst (prvoid_type_node, 0)); + tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, + gfc_unlikely (tmp, + PRED_FORTRAN_FAIL_ALLOC), + gfc_finish_block (&alloc), + build_empty_stmt (input_location)); + gfc_add_expr_to_block (&lse->pre, tmp); + } + + fcn = gfc_vptr_copy_get (vptr); tmp = GFC_CLASS_TYPE_P (TREE_TYPE (rse->expr)) ? gfc_class_data_get (rse->expr) : rse->expr; @@ -9961,15 +9982,10 @@ gfc_trans_assignment_1 (gfc_expr * expr1, gfc_expr * expr2, bool init_flag, } if (is_poly_assign) - { - tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse, - use_vptr_copy || (lhs_attr.allocatable - && !lhs_attr.dimension)); - /* 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); - } + tmp = trans_class_assignment (&body, expr1, expr2, &lse, &rse, + use_vptr_copy || (lhs_attr.allocatable + && !lhs_attr.dimension), + flag_realloc_lhs && !lhs_attr.pointer); else if (flag_coarray == GFC_FCOARRAY_LIB && lhs_caf_attr.codimension && rhs_caf_attr.codimension && ((lhs_caf_attr.allocatable && lhs_refs_comp) @@ -10011,7 +10027,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/ChangeLog b/gcc/testsuite/ChangeLog index f208f08..969c896 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2016-12-23 Andre Vehreschild <vehre@gcc.gnu.org> + + * gfortran.dg/class_assign_1.f08: New test. + 2016-12-23 Toma Tabacu <toma.tabacu@imgtec.com> * gcc.target/mips/oddspreg-2.c (dg-options): Remove dg-skip-if for 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 + |