Commit fc7d0afb by Andre Vehreschild Committed by Andre Vehreschild

re PR fortran/59678 ([F03] Segfault on equalizing variables of a complex derived type)

gcc/fortran
2015-04-27  Andre Vehreschild  <vehre@gmx.de>

        PR fortran/59678
        PR fortran/65841
        * trans-array.c (duplicate_allocatable): Fixed deep copy of
        allocatable components, which are liable for copy only, when
        they are allocated.
        (gfc_duplicate_allocatable): Add deep-copy code into if
        component allocated block. Needed interface change for that.
        (gfc_copy_allocatable_data): Supplying NULL_TREE for code to
        add into if-block for checking whether a component was
        allocated.
        (gfc_duplicate_allocatable_nocopy): Likewise.
        (structure_alloc_comps): Likewise.
        * trans-array.h: Likewise.
        * trans-expr.c (gfc_trans_alloc_subarray_assign): Likewise.
        * trans-openmp.c (gfc_walk_alloc_comps): Likewise.

gcc/testsuite
2015-04-27  Andre Vehreschild  <vehre@gmx.de>

        PR fortran/59678
        PR fortran/65841
        * gfortran.dg/alloc_comp_deep_copy_1.f03: New test.
        * gfortran.dg/alloc_comp_deep_copy_2.f03: New test.

From-SVN: r222477
parent 16d710b1
2015-04-27 Andre Vehreschild <vehre@gmx.de>
PR fortran/59678
PR fortran/65841
* trans-array.c (duplicate_allocatable): Fixed deep copy of
allocatable components, which are liable for copy only, when
they are allocated.
(gfc_duplicate_allocatable): Add deep-copy code into if
component allocated block. Needed interface change for that.
(gfc_copy_allocatable_data): Supplying NULL_TREE for code to
add into if-block for checking whether a component was
allocated.
(gfc_duplicate_allocatable_nocopy): Likewise.
(structure_alloc_comps): Likewise.
* trans-array.h: Likewise.
* trans-expr.c (gfc_trans_alloc_subarray_assign): Likewise.
* trans-openmp.c (gfc_walk_alloc_comps): Likewise.
2015-04-23 Andre Vehreschild <vehre@gmx.de> 2015-04-23 Andre Vehreschild <vehre@gmx.de>
PR fortran/60322 PR fortran/60322
......
...@@ -7523,7 +7523,8 @@ gfc_full_array_size (stmtblock_t *block, tree decl, int rank) ...@@ -7523,7 +7523,8 @@ gfc_full_array_size (stmtblock_t *block, tree decl, int rank)
static tree static tree
duplicate_allocatable (tree dest, tree src, tree type, int rank, duplicate_allocatable (tree dest, tree src, tree type, int rank,
bool no_malloc, bool no_memcpy, tree str_sz) bool no_malloc, bool no_memcpy, tree str_sz,
tree add_when_allocated)
{ {
tree tmp; tree tmp;
tree size; tree size;
...@@ -7603,6 +7604,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, ...@@ -7603,6 +7604,7 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
} }
} }
gfc_add_expr_to_block (&block, add_when_allocated);
tmp = gfc_finish_block (&block); tmp = gfc_finish_block (&block);
/* Null the destination if the source is null; otherwise do /* Null the destination if the source is null; otherwise do
...@@ -7622,10 +7624,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank, ...@@ -7622,10 +7624,11 @@ duplicate_allocatable (tree dest, tree src, tree type, int rank,
/* Allocate dest to the same size as src, and copy data src -> dest. */ /* Allocate dest to the same size as src, and copy data src -> dest. */
tree tree
gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank) gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank,
tree add_when_allocated)
{ {
return duplicate_allocatable (dest, src, type, rank, false, false, return duplicate_allocatable (dest, src, type, rank, false, false,
NULL_TREE); NULL_TREE, add_when_allocated);
} }
...@@ -7635,7 +7638,7 @@ tree ...@@ -7635,7 +7638,7 @@ tree
gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
{ {
return duplicate_allocatable (dest, src, type, rank, true, false, return duplicate_allocatable (dest, src, type, rank, true, false,
NULL_TREE); NULL_TREE, NULL_TREE);
} }
/* Allocate dest to the same size as src, but don't copy anything. */ /* Allocate dest to the same size as src, but don't copy anything. */
...@@ -7643,7 +7646,8 @@ gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) ...@@ -7643,7 +7646,8 @@ gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank)
tree tree
gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank) gfc_duplicate_allocatable_nocopy (tree dest, tree src, tree type, int rank)
{ {
return duplicate_allocatable (dest, src, type, rank, false, true, NULL_TREE); return duplicate_allocatable (dest, src, type, rank, false, true,
NULL_TREE, NULL_TREE);
} }
...@@ -7675,27 +7679,32 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -7675,27 +7679,32 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
tree ctype; tree ctype;
tree vref, dref; tree vref, dref;
tree null_cond = NULL_TREE; tree null_cond = NULL_TREE;
tree add_when_allocated;
bool called_dealloc_with_status; bool called_dealloc_with_status;
gfc_init_block (&fnblock); gfc_init_block (&fnblock);
decl_type = TREE_TYPE (decl); decl_type = TREE_TYPE (decl);
if ((POINTER_TYPE_P (decl_type) && rank != 0) if ((POINTER_TYPE_P (decl_type))
|| (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0)) || (TREE_CODE (decl_type) == REFERENCE_TYPE && rank == 0))
decl = build_fold_indirect_ref_loc (input_location, decl); {
decl = build_fold_indirect_ref_loc (input_location, decl);
/* Deref dest in sync with decl, but only when it is not NULL. */
if (dest)
dest = build_fold_indirect_ref_loc (input_location, dest);
}
/* Just in case in gets dereferenced. */ /* Just in case it gets dereferenced. */
decl_type = TREE_TYPE (decl); decl_type = TREE_TYPE (decl);
/* If this an array of derived types with allocatable components /* If this is an array of derived types with allocatable components
build a loop and recursively call this function. */ build a loop and recursively call this function. */
if (TREE_CODE (decl_type) == ARRAY_TYPE if (TREE_CODE (decl_type) == ARRAY_TYPE
|| (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0)) || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0))
{ {
tmp = gfc_conv_array_data (decl); tmp = gfc_conv_array_data (decl);
var = build_fold_indirect_ref_loc (input_location, var = build_fold_indirect_ref_loc (input_location, tmp);
tmp);
/* Get the number of elements - 1 and set the counter. */ /* Get the number of elements - 1 and set the counter. */
if (GFC_DESCRIPTOR_TYPE_P (decl_type)) if (GFC_DESCRIPTOR_TYPE_P (decl_type))
...@@ -7716,7 +7725,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -7716,7 +7725,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
else else
{ {
/* Otherwise use the TYPE_DOMAIN information. */ /* Otherwise use the TYPE_DOMAIN information. */
tmp = array_type_nelts (decl_type); tmp = array_type_nelts (decl_type);
tmp = fold_convert (gfc_array_index_type, tmp); tmp = fold_convert (gfc_array_index_type, tmp);
} }
...@@ -7729,19 +7738,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -7729,19 +7738,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
vref = gfc_build_array_ref (var, index, NULL); vref = gfc_build_array_ref (var, index, NULL);
if (purpose == COPY_ALLOC_COMP) if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP)
{
if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
{
tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank);
gfc_add_expr_to_block (&fnblock, tmp);
}
tmp = build_fold_indirect_ref_loc (input_location,
gfc_conv_array_data (dest));
dref = gfc_build_array_ref (tmp, index, NULL);
tmp = structure_alloc_comps (der_type, vref, dref, rank, purpose);
}
else if (purpose == COPY_ONLY_ALLOC_COMP)
{ {
tmp = build_fold_indirect_ref_loc (input_location, tmp = build_fold_indirect_ref_loc (input_location,
gfc_conv_array_data (dest)); gfc_conv_array_data (dest));
...@@ -7764,7 +7761,17 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -7764,7 +7761,17 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
gfc_add_block_to_block (&fnblock, &loop.pre); gfc_add_block_to_block (&fnblock, &loop.pre);
tmp = gfc_finish_block (&fnblock); tmp = gfc_finish_block (&fnblock);
if (null_cond != NULL_TREE) /* When copying allocateable components, the above implements the
deep copy. Nevertheless is a deep copy only allowed, when the current
component is allocated, for which code will be generated in
gfc_duplicate_allocatable (), where the deep copy code is just added
into the if's body, by adding tmp (the deep copy code) as last
argument to gfc_duplicate_allocatable (). */
if (purpose == COPY_ALLOC_COMP
&& GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (dest)))
tmp = gfc_duplicate_allocatable (dest, decl, decl_type, rank,
tmp);
else if (null_cond != NULL_TREE)
tmp = build3_v (COND_EXPR, null_cond, tmp, tmp = build3_v (COND_EXPR, null_cond, tmp,
build_empty_stmt (input_location)); build_empty_stmt (input_location));
...@@ -8049,6 +8056,22 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -8049,6 +8056,22 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
continue; continue;
} }
/* To implement guarded deep copy, i.e., deep copy only allocatable
components that are really allocated, the deep copy code has to
be generated first and then added to the if-block in
gfc_duplicate_allocatable (). */
if (cmp_has_alloc_comps)
{
rank = c->as ? c->as->rank : 0;
tmp = fold_convert (TREE_TYPE (dcmp), comp);
gfc_add_modify (&fnblock, dcmp, tmp);
add_when_allocated = structure_alloc_comps (c->ts.u.derived,
comp, dcmp,
rank, purpose);
}
else
add_when_allocated = NULL_TREE;
if (gfc_deferred_strlen (c, &tmp)) if (gfc_deferred_strlen (c, &tmp))
{ {
tree len, size; tree len, size;
...@@ -8063,30 +8086,29 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, ...@@ -8063,30 +8086,29 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl,
TREE_TYPE (len), len, tmp); TREE_TYPE (len), len, tmp);
gfc_add_expr_to_block (&fnblock, tmp); gfc_add_expr_to_block (&fnblock, tmp);
size = size_of_string_in_bytes (c->ts.kind, len); size = size_of_string_in_bytes (c->ts.kind, len);
/* This component can not have allocatable components,
therefore add_when_allocated of duplicate_allocatable ()
is always NULL. */
tmp = duplicate_allocatable (dcmp, comp, ctype, rank, tmp = duplicate_allocatable (dcmp, comp, ctype, rank,
false, false, size); false, false, size, NULL_TREE);
gfc_add_expr_to_block (&fnblock, tmp); gfc_add_expr_to_block (&fnblock, tmp);
} }
else if (c->attr.allocatable && !c->attr.proc_pointer else if (c->attr.allocatable && !c->attr.proc_pointer
&& !cmp_has_alloc_comps) && (!(cmp_has_alloc_comps && c->as)
|| c->attr.codimension))
{ {
rank = c->as ? c->as->rank : 0; rank = c->as ? c->as->rank : 0;
if (c->attr.codimension) if (c->attr.codimension)
tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank); tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank);
else else
tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank); tmp = gfc_duplicate_allocatable (dcmp, comp, ctype, rank,
add_when_allocated);
gfc_add_expr_to_block (&fnblock, tmp); gfc_add_expr_to_block (&fnblock, tmp);
} }
else
if (cmp_has_alloc_comps)
gfc_add_expr_to_block (&fnblock, add_when_allocated);
if (cmp_has_alloc_comps)
{
rank = c->as ? c->as->rank : 0;
tmp = fold_convert (TREE_TYPE (dcmp), comp);
gfc_add_modify (&fnblock, dcmp, tmp);
tmp = structure_alloc_comps (c->ts.u.derived, comp, dcmp,
rank, purpose);
gfc_add_expr_to_block (&fnblock, tmp);
}
break; break;
default: default:
......
...@@ -46,7 +46,7 @@ tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *); ...@@ -46,7 +46,7 @@ tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *);
tree gfc_full_array_size (stmtblock_t *, tree, int); tree gfc_full_array_size (stmtblock_t *, tree, int);
tree gfc_duplicate_allocatable (tree dest, tree src, tree type, int rank); tree gfc_duplicate_allocatable (tree, tree, tree, int, tree);
tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank); tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank);
......
...@@ -6713,13 +6713,13 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, ...@@ -6713,13 +6713,13 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm,
{ {
tmp = TREE_TYPE (dest); tmp = TREE_TYPE (dest);
tmp = gfc_duplicate_allocatable (dest, se.expr, tmp = gfc_duplicate_allocatable (dest, se.expr,
tmp, expr->rank); tmp, expr->rank, NULL_TREE);
} }
} }
else else
tmp = gfc_duplicate_allocatable (dest, se.expr, tmp = gfc_duplicate_allocatable (dest, se.expr,
TREE_TYPE(cm->backend_decl), TREE_TYPE(cm->backend_decl),
cm->as->rank); cm->as->rank, NULL_TREE);
gfc_add_expr_to_block (&block, tmp); gfc_add_expr_to_block (&block, tmp);
gfc_add_block_to_block (&block, &se.post); gfc_add_block_to_block (&block, &se.post);
......
...@@ -391,9 +391,11 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var, ...@@ -391,9 +391,11 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var,
if (GFC_DESCRIPTOR_TYPE_P (ftype) if (GFC_DESCRIPTOR_TYPE_P (ftype)
&& GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE)
tem = gfc_duplicate_allocatable (destf, declf, ftype, tem = gfc_duplicate_allocatable (destf, declf, ftype,
GFC_TYPE_ARRAY_RANK (ftype)); GFC_TYPE_ARRAY_RANK (ftype),
NULL_TREE);
else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field)) else if (GFC_DECL_GET_SCALAR_ALLOCATABLE (field))
tem = gfc_duplicate_allocatable (destf, declf, ftype, 0); tem = gfc_duplicate_allocatable (destf, declf, ftype, 0,
NULL_TREE);
break; break;
} }
if (tem) if (tem)
......
2015-04-27 Andre Vehreschild <vehre@gmx.de>
PR fortran/59678
PR fortran/65841
* gfortran.dg/alloc_comp_deep_copy_1.f03: New test.
* gfortran.dg/alloc_comp_deep_copy_2.f03: New test.
2015-04-27 Caroline Tice <cmtice@google.com> 2015-04-27 Caroline Tice <cmtice@google.com>
* gcc.dg/tree-prof/cold_partition_label.c (main): Check for cold * gcc.dg/tree-prof/cold_partition_label.c (main): Check for cold
......
! { dg-do run }
!
! Check fix for correctly deep copying allocatable components.
! PR fortran/59678
! Contributed by Andre Vehreschild <vehre@gmx.de>
!
program alloc_comp_copy_test
type InnerT
integer :: ii
integer, allocatable :: ai
integer, allocatable :: v(:)
end type InnerT
type T
integer :: i
integer, allocatable :: a_i
type(InnerT), allocatable :: it
type(InnerT), allocatable :: vec(:)
end type T
type(T) :: o1, o2
class(T), allocatable :: o3, o4
o1%i = 42
call copyO(o1, o2)
if (o2%i /= 42) call abort ()
if (allocated(o2%a_i)) call abort()
if (allocated(o2%it)) call abort()
if (allocated(o2%vec)) call abort()
allocate (o1%a_i, source=2)
call copyO(o1, o2)
if (o2%i /= 42) call abort ()
if (.not. allocated(o2%a_i)) call abort()
if (o2%a_i /= 2) call abort()
if (allocated(o2%it)) call abort()
if (allocated(o2%vec)) call abort()
allocate (o1%it)
o1%it%ii = 3
call copyO(o1, o2)
if (o2%i /= 42) call abort ()
if (.not. allocated(o2%a_i)) call abort()
if (o2%a_i /= 2) call abort()
if (.not. allocated(o2%it)) call abort()
if (o2%it%ii /= 3) call abort()
if (allocated(o2%it%ai)) call abort()
if (allocated(o2%it%v)) call abort()
if (allocated(o2%vec)) call abort()
allocate (o1%it%ai)
o1%it%ai = 4
call copyO(o1, o2)
if (o2%i /= 42) call abort ()
if (.not. allocated(o2%a_i)) call abort()
if (o2%a_i /= 2) call abort()
if (.not. allocated(o2%it)) call abort()
if (o2%it%ii /= 3) call abort()
if (.not. allocated(o2%it%ai)) call abort()
if (o2%it%ai /= 4) call abort()
if (allocated(o2%it%v)) call abort()
if (allocated(o2%vec)) call abort()
allocate (o1%it%v(3), source= 5)
call copyO(o1, o2)
if (o2%i /= 42) call abort ()
if (.not. allocated(o2%a_i)) call abort()
if (o2%a_i /= 2) call abort()
if (.not. allocated(o2%it)) call abort()
if (o2%it%ii /= 3) call abort()
if (.not. allocated(o2%it%ai)) call abort()
if (o2%it%ai /= 4) call abort()
if (.not. allocated(o2%it%v)) call abort()
if (any (o2%it%v /= 5) .or. size (o2%it%v) /= 3) call abort()
if (allocated(o2%vec)) call abort()
allocate (o1%vec(2))
o1%vec(:)%ii = 6
call copyO(o1, o2)
if (o2%i /= 42) call abort ()
if (.not. allocated(o2%a_i)) call abort()
if (o2%a_i /= 2) call abort()
if (.not. allocated(o2%it)) call abort()
if (o2%it%ii /= 3) call abort()
if (.not. allocated(o2%it%ai)) call abort()
if (o2%it%ai /= 4) call abort()
if (.not. allocated(o2%it%v)) call abort()
if (size (o2%it%v) /= 3) call abort()
if (any (o2%it%v /= 5)) call abort()
if (.not. allocated(o2%vec)) call abort()
if (size(o2%vec) /= 2) call abort()
if (any(o2%vec(:)%ii /= 6)) call abort()
if (allocated(o2%vec(1)%ai) .or. allocated(o2%vec(2)%ai)) call abort()
if (allocated(o2%vec(1)%v) .or. allocated(o2%vec(2)%v)) call abort()
allocate (o1%vec(2)%ai)
o1%vec(2)%ai = 7
call copyO(o1, o2)
if (o2%i /= 42) call abort ()
if (.not. allocated(o2%a_i)) call abort()
if (o2%a_i /= 2) call abort()
if (.not. allocated(o2%it)) call abort()
if (o2%it%ii /= 3) call abort()
if (.not. allocated(o2%it%ai)) call abort()
if (o2%it%ai /= 4) call abort()
if (.not. allocated(o2%it%v)) call abort()
if (size (o2%it%v) /= 3) call abort()
if (any (o2%it%v /= 5)) call abort()
if (.not. allocated(o2%vec)) call abort()
if (size(o2%vec) /= 2) call abort()
if (any(o2%vec(:)%ii /= 6)) call abort()
if (allocated(o2%vec(1)%ai)) call abort()
if (.not. allocated(o2%vec(2)%ai)) call abort()
if (o2%vec(2)%ai /= 7) call abort()
if (allocated(o2%vec(1)%v) .or. allocated(o2%vec(2)%v)) call abort()
allocate (o1%vec(1)%v(3))
o1%vec(1)%v = [8, 9, 10]
call copyO(o1, o2)
if (o2%i /= 42) call abort ()
if (.not. allocated(o2%a_i)) call abort()
if (o2%a_i /= 2) call abort()
if (.not. allocated(o2%it)) call abort()
if (o2%it%ii /= 3) call abort()
if (.not. allocated(o2%it%ai)) call abort()
if (o2%it%ai /= 4) call abort()
if (.not. allocated(o2%it%v)) call abort()
if (size (o2%it%v) /= 3) call abort()
if (any (o2%it%v /= 5)) call abort()
if (.not. allocated(o2%vec)) call abort()
if (size(o2%vec) /= 2) call abort()
if (any(o2%vec(:)%ii /= 6)) call abort()
if (allocated(o2%vec(1)%ai)) call abort()
if (.not. allocated(o2%vec(2)%ai)) call abort()
if (o2%vec(2)%ai /= 7) call abort()
if (.not. allocated(o2%vec(1)%v)) call abort()
if (any (o2%vec(1)%v /= [8,9,10])) call abort()
if (allocated(o2%vec(2)%v)) call abort()
! Now all the above for class objects.
allocate (o3, o4)
o3%i = 42
call copyO(o3, o4)
if (o4%i /= 42) call abort ()
if (allocated(o4%a_i)) call abort()
if (allocated(o4%it)) call abort()
if (allocated(o4%vec)) call abort()
allocate (o3%a_i, source=2)
call copyO(o3, o4)
if (o4%i /= 42) call abort ()
if (.not. allocated(o4%a_i)) call abort()
if (o4%a_i /= 2) call abort()
if (allocated(o4%it)) call abort()
if (allocated(o4%vec)) call abort()
allocate (o3%it)
o3%it%ii = 3
call copyO(o3, o4)
if (o4%i /= 42) call abort ()
if (.not. allocated(o4%a_i)) call abort()
if (o4%a_i /= 2) call abort()
if (.not. allocated(o4%it)) call abort()
if (o4%it%ii /= 3) call abort()
if (allocated(o4%it%ai)) call abort()
if (allocated(o4%it%v)) call abort()
if (allocated(o4%vec)) call abort()
allocate (o3%it%ai)
o3%it%ai = 4
call copyO(o3, o4)
if (o4%i /= 42) call abort ()
if (.not. allocated(o4%a_i)) call abort()
if (o4%a_i /= 2) call abort()
if (.not. allocated(o4%it)) call abort()
if (o4%it%ii /= 3) call abort()
if (.not. allocated(o4%it%ai)) call abort()
if (o4%it%ai /= 4) call abort()
if (allocated(o4%it%v)) call abort()
if (allocated(o4%vec)) call abort()
allocate (o3%it%v(3), source= 5)
call copyO(o3, o4)
if (o4%i /= 42) call abort ()
if (.not. allocated(o4%a_i)) call abort()
if (o4%a_i /= 2) call abort()
if (.not. allocated(o4%it)) call abort()
if (o4%it%ii /= 3) call abort()
if (.not. allocated(o4%it%ai)) call abort()
if (o4%it%ai /= 4) call abort()
if (.not. allocated(o4%it%v)) call abort()
if (any (o4%it%v /= 5) .or. size (o4%it%v) /= 3) call abort()
if (allocated(o4%vec)) call abort()
allocate (o3%vec(2))
o3%vec(:)%ii = 6
call copyO(o3, o4)
if (o4%i /= 42) call abort ()
if (.not. allocated(o4%a_i)) call abort()
if (o4%a_i /= 2) call abort()
if (.not. allocated(o4%it)) call abort()
if (o4%it%ii /= 3) call abort()
if (.not. allocated(o4%it%ai)) call abort()
if (o4%it%ai /= 4) call abort()
if (.not. allocated(o4%it%v)) call abort()
if (size (o4%it%v) /= 3) call abort()
if (any (o4%it%v /= 5)) call abort()
if (.not. allocated(o4%vec)) call abort()
if (size(o4%vec) /= 2) call abort()
if (any(o4%vec(:)%ii /= 6)) call abort()
if (allocated(o4%vec(1)%ai) .or. allocated(o4%vec(2)%ai)) call abort()
if (allocated(o4%vec(1)%v) .or. allocated(o4%vec(2)%v)) call abort()
allocate (o3%vec(2)%ai)
o3%vec(2)%ai = 7
call copyO(o3, o4)
if (o4%i /= 42) call abort ()
if (.not. allocated(o4%a_i)) call abort()
if (o4%a_i /= 2) call abort()
if (.not. allocated(o4%it)) call abort()
if (o4%it%ii /= 3) call abort()
if (.not. allocated(o4%it%ai)) call abort()
if (o4%it%ai /= 4) call abort()
if (.not. allocated(o4%it%v)) call abort()
if (size (o4%it%v) /= 3) call abort()
if (any (o4%it%v /= 5)) call abort()
if (.not. allocated(o4%vec)) call abort()
if (size(o4%vec) /= 2) call abort()
if (any(o4%vec(:)%ii /= 6)) call abort()
if (allocated(o4%vec(1)%ai)) call abort()
if (.not. allocated(o4%vec(2)%ai)) call abort()
if (o4%vec(2)%ai /= 7) call abort()
if (allocated(o4%vec(1)%v) .or. allocated(o4%vec(2)%v)) call abort()
allocate (o3%vec(1)%v(3))
o3%vec(1)%v = [8, 9, 10]
call copyO(o3, o4)
if (o4%i /= 42) call abort ()
if (.not. allocated(o4%a_i)) call abort()
if (o4%a_i /= 2) call abort()
if (.not. allocated(o4%it)) call abort()
if (o4%it%ii /= 3) call abort()
if (.not. allocated(o4%it%ai)) call abort()
if (o4%it%ai /= 4) call abort()
if (.not. allocated(o4%it%v)) call abort()
if (size (o4%it%v) /= 3) call abort()
if (any (o4%it%v /= 5)) call abort()
if (.not. allocated(o4%vec)) call abort()
if (size(o4%vec) /= 2) call abort()
if (any(o4%vec(:)%ii /= 6)) call abort()
if (allocated(o4%vec(1)%ai)) call abort()
if (.not. allocated(o4%vec(2)%ai)) call abort()
if (o4%vec(2)%ai /= 7) call abort()
if (.not. allocated(o4%vec(1)%v)) call abort()
if (any (o4%vec(1)%v /= [8,9,10])) call abort()
if (allocated(o4%vec(2)%v)) call abort()
contains
subroutine copyO(src, dst)
type(T), intent(in) :: src
type(T), intent(out) :: dst
dst = src
end subroutine copyO
end program alloc_comp_copy_test
! { dg-do run }
!
! Testcase for PR fortran/65841
! Contributed by Damian Rousson
!
program alloc_comp_deep_copy_2
type a
real, allocatable :: f
end type
type b
type(a), allocatable :: g
end type
type(b) c,d
c%g=a(1.)
d=c
if (d%g%f /= 1.0) call abort()
d%g%f = 2.0
if (d%g%f /= 2.0) call abort()
end program
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment