From: Mikael Morin Date: Sat, 16 May 2015 08:09:52 +0000 (+0000) Subject: 2015-05-16 Mikael Morin PR fortran/65792 * trans-expr.c (gfc_trans_subcomponent_assign): Always assign the expression component to the destination. In addition, if the component has allocatable components, copy them and deallocate those of the expression, if it is not a variable. The expression is fixed if not a variable to prevent multiple evaluations. 2015-05-16 Mikael Morin PR fortran/65792 * gfortran.dg/derived_constructor_components_5: New test From-SVN: r223234 --- diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 1b455b56e0f..c06627e32c9 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,14 @@ +2015-05-16 Mikael Morin + + PR fortran/65792 + * trans-expr.c (gfc_trans_subcomponent_assign): Always assign + the expression component to the destination. In addition, if + the component has allocatable components, copy them and + deallocate those of the expression, if it is not a variable. + The expression is fixed if not a variable to prevent multiple + evaluations. + 2015-05-12 Thomas Koenig PR fortran/66111 @@ -133,12 +144,12 @@ to be referenced always. (build_class_array_ref): Adapt retrieval of array descriptor. (build_array_ref): Likewise. - (gfc_conv_array_ref): Hand the vptr or the descriptor to + (gfc_conv_array_ref): Hand the vptr or the descriptor to build_array_ref depending whether the sym is class or not. (gfc_trans_array_cobounds): Select correct gfc_array_spec for regular and class arrays. (gfc_trans_array_bounds): Likewise. - (gfc_trans_dummy_array_bias): Likewise. + (gfc_trans_dummy_array_bias): Likewise. (gfc_get_dataptr_offset): Correcting call of build_array_ref. (gfc_conv_expr_descriptor): Set the array's offset to -1 when lbound in inner most dim is 1 and symbol non-pointer/assoc. diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index c71037f7b9a..9be8a4206fa 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -7050,19 +7050,31 @@ gfc_trans_subcomponent_assign (tree dest, gfc_component * cm, gfc_expr * expr, { if (expr->expr_type != EXPR_STRUCTURE) { + tree dealloc = NULL_TREE; gfc_init_se (&se, NULL); gfc_conv_expr (&se, expr); gfc_add_block_to_block (&block, &se.pre); + /* Prevent repeat evaluations in gfc_copy_alloc_comp by fixing the + expression in a temporary variable and deallocate the allocatable + components. Then we can the copy the expression to the result. */ if (cm->ts.u.derived->attr.alloc_comp - && expr->expr_type == EXPR_VARIABLE) + && expr->expr_type != EXPR_VARIABLE) + { + se.expr = gfc_evaluate_now (se.expr, &block); + dealloc = gfc_deallocate_alloc_comp (cm->ts.u.derived, se.expr, + expr->rank); + } + gfc_add_modify (&block, dest, + fold_convert (TREE_TYPE (dest), se.expr)); + if (cm->ts.u.derived->attr.alloc_comp + && expr->expr_type != EXPR_NULL) { tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr, dest, expr->rank); gfc_add_expr_to_block (&block, tmp); + if (dealloc != NULL_TREE) + gfc_add_expr_to_block (&block, dealloc); } - else - gfc_add_modify (&block, dest, - fold_convert (TREE_TYPE (dest), se.expr)); gfc_add_block_to_block (&block, &se.post); } else diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 123dadfbaf3..7d58a1883a1 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,8 @@ +2015-05-16 Mikael Morin + + PR fortran/65792 + * gfortran.dg/derived_constructor_components_5: New test + 2015-05-16 Uros Bizjak PR target/66140 diff --git a/gcc/testsuite/gfortran.dg/derived_constructor_comps_5.f90 b/gcc/testsuite/gfortran.dg/derived_constructor_comps_5.f90 new file mode 100644 index 00000000000..083c1313042 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/derived_constructor_comps_5.f90 @@ -0,0 +1,59 @@ +! { dg-do run } +! +! PR fortran/65792 +! The evaluation of the argument in the call to new_prt_spec2 +! failed to properly initialize the comp component. +! While the array contents were properly copied, the array bounds remained +! uninitialized. +! +! Contributed by Dominique D'Humieres + +program main + implicit none + + integer, parameter :: n = 2 + + type :: string_t + character(LEN=1), dimension(:), allocatable :: chars + end type string_t + + type :: string_container_t + type(string_t) :: comp + end type string_container_t + + type(string_t) :: prt_in, tmp, tmpa(n) + type(string_container_t) :: tmpc, tmpca(n) + integer :: i, j, k + + do i=1,2 + +! scalar elemental function with structure constructor + prt_in = string_t(["D"]) + tmpc = new_prt_spec2 (string_container_t(prt_in)) + if (any(tmpc%comp%chars .ne. ["D"])) call abort + deallocate (prt_in%chars) + deallocate(tmpc%comp%chars) +! Check that function arguments are OK too + tmpc = new_prt_spec2 (string_container_t(new_str_t(["h","e","l","l","o"]))) + if (any(tmpc%comp%chars .ne. ["h","e","l","l","o"])) call abort + deallocate(tmpc%comp%chars) + + end do + +contains + + impure elemental function new_prt_spec2 (name) result (prt_spec) + type(string_container_t), intent(in) :: name + type(string_container_t) :: prt_spec + prt_spec = name + end function new_prt_spec2 + + + function new_str_t (name) result (prt_spec) + character (*), intent(in), dimension (:) :: name + type(string_t) :: prt_spec + prt_spec = string_t(name) + end function new_str_t + +end program main +