Hello,
here is a fix for PR65792 where a structure constructor used as actual
argument was not fully initialized.
The test looks like the following...
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
[...]
tmpc = new_prt_spec2 (string_container_t(prt_in))
The problem is in gfc_trans_subcomponent_assign, when initialising the
component comp with prt_in:
if (cm->ts.u.derived->attr.alloc_comp
&& expr->expr_type == EXPR_VARIABLE)
{
tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
dest, expr->rank);
gfc_add_expr_to_block (&block, tmp);
}
else
gfc_add_modify (&block, dest,
fold_convert (TREE_TYPE (dest), se.expr));
The if branch deep copies allocatable components, but does nothing for
other components, which is the case here (the array elements are copied,
not the array bounds).
The patch proposed here for backport, moves the existing shallow copy
out of the else branch.
For trunk, I wanted to reuse gfc_trans_scalar_assign which has all the
logic for copying stuff around. And as gfc_trans_scalar_assign is used
as fallback a few lines down, I have tried to use that fallback.
This change of control flow makes the patch a bit more risky, so I
prefer to use the other variant for the branches.
Setting the deep_copy argument of gfc_trans_scalar_assign to true is
necessary so that gfc_copy_alloc_comp is called as before.
Because of the branch the patch removes, I think the fallback code was
unreachable for non-derived types, and for those the deep_copy flag was
irrelevant anyway, so that that change should be rather harmless.
Both patches have been regression tested on trunk on x86_64-linux.
OK for trunk [first patch]?
OK for 4.9 and 5 (after the 5.1 release) [second patch]?
Mikael
PS: Dominiq reported that the variant of this patch posted on the PR was
also fixing PR49324. I couldn't confirm as what seems to be the
remaining testcase there (comment #6) doesn't fail with trunk here.
2015-04-18 Mikael Morin <mik...@gcc.gnu.org>
PR fortran/65792
* trans-expr.c (gfc_trans_subcomponent_assign):
Don't special case non-structure-constructor derived type
expressions. Enable deep copying.
2015-04-18 Mikael Morin <mik...@gcc.gnu.org>
PR fortran/65792
* gfortran.dg/derived_constructor_comps_5.f90: New.
Index: trans-expr.c
===================================================================
--- trans-expr.c (révision 221972)
+++ trans-expr.c (copie de travail)
@@ -6908,32 +6908,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_comp
fold_convert (TREE_TYPE (tmp), se.expr));
gfc_add_block_to_block (&block, &se.post);
}
- else if (expr->ts.type == BT_DERIVED && expr->ts.f90_type != BT_VOID)
- {
- if (expr->expr_type != EXPR_STRUCTURE)
- {
- gfc_init_se (&se, NULL);
- gfc_conv_expr (&se, expr);
- gfc_add_block_to_block (&block, &se.pre);
- if (cm->ts.u.derived->attr.alloc_comp
- && expr->expr_type == EXPR_VARIABLE)
- {
- tmp = gfc_copy_alloc_comp (cm->ts.u.derived, se.expr,
- dest, expr->rank);
- gfc_add_expr_to_block (&block, tmp);
- }
- else
- gfc_add_modify (&block, dest,
- fold_convert (TREE_TYPE (dest), se.expr));
- gfc_add_block_to_block (&block, &se.post);
- }
- else
- {
- /* Nested constructors. */
- tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
- gfc_add_expr_to_block (&block, tmp);
- }
- }
else if (gfc_deferred_strlen (cm, &tmp))
{
tree strlen;
@@ -6967,6 +6941,13 @@ gfc_trans_subcomponent_assign (tree dest, gfc_comp
gfc_add_expr_to_block (&block, tmp);
}
}
+ else if (expr->expr_type == EXPR_STRUCTURE
+ && expr->ts.f90_type != BT_VOID)
+ {
+ /* Nested constructors. */
+ tmp = gfc_trans_structure_assign (dest, expr, expr->symtree != NULL);
+ gfc_add_expr_to_block (&block, tmp);
+ }
else if (!cm->attr.artificial)
{
/* Scalar component (excluding deferred parameters). */
@@ -6977,7 +6958,7 @@ gfc_trans_subcomponent_assign (tree dest, gfc_comp
if (cm->ts.type == BT_CHARACTER)
lse.string_length = cm->ts.u.cl->backend_decl;
lse.expr = dest;
- tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, false, true);
+ tmp = gfc_trans_scalar_assign (&lse, &se, cm->ts, true, true, true);
gfc_add_expr_to_block (&block, tmp);
}
return gfc_finish_block (&block);
2015-04-18 Mikael Morin <mik...@gcc.gnu.org>
PR fortran/65792
* trans-expr.c (gfc_trans_subcomponent_assign):
Always (shallow) copy the subcomponent.
2015-04-18 Mikael Morin <mik...@gcc.gnu.org>
PR fortran/65792
* gfortran.dg/derived_constructor_comps_5.f90: New.
Index: trans-expr.c
===================================================================
--- trans-expr.c (révision 221972)
+++ trans-expr.c (copie de travail)
@@ -6915,6 +6935,8 @@ gfc_trans_subcomponent_assign (tree dest, gfc_comp
gfc_init_se (&se, NULL);
gfc_conv_expr (&se, expr);
gfc_add_block_to_block (&block, &se.pre);
+ gfc_add_modify (&block, dest,
+ fold_convert (TREE_TYPE (dest), se.expr));
if (cm->ts.u.derived->attr.alloc_comp
&& expr->expr_type == EXPR_VARIABLE)
{
@@ -6922,9 +6944,6 @@ gfc_trans_subcomponent_assign (tree dest, gfc_comp
dest, expr->rank);
gfc_add_expr_to_block (&block, tmp);
}
- else
- gfc_add_modify (&block, dest,
- fold_convert (TREE_TYPE (dest), se.expr));
gfc_add_block_to_block (&block, &se.post);
}
else
! { 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 <domi...@lps.ens.fr>
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,16
! scalar elemental function with structure constructor
prt_in = string_t(["D"])
tmpc = new_prt_spec2 (string_container_t(prt_in))
deallocate (prt_in%chars)
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
end program main
