From fc7d0afb9c70f466189c433962bab41a84765b0f Mon Sep 17 00:00:00 2001 From: Andre Vehreschild Date: Mon, 27 Apr 2015 19:34:11 +0200 Subject: [PATCH] re PR fortran/59678 ([F03] Segfault on equalizing variables of a complex derived type) gcc/fortran 2015-04-27 Andre Vehreschild 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 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 --- gcc/fortran/ChangeLog | 18 ++ gcc/fortran/trans-array.c | 98 ++++--- gcc/fortran/trans-array.h | 2 +- gcc/fortran/trans-expr.c | 4 +- gcc/fortran/trans-openmp.c | 6 +- gcc/testsuite/ChangeLog | 7 + .../gfortran.dg/alloc_comp_deep_copy_1.f03 | 270 ++++++++++++++++++ .../gfortran.dg/alloc_comp_deep_copy_2.f03 | 21 ++ 8 files changed, 383 insertions(+), 43 deletions(-) create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 create mode 100644 gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_2.f03 diff --git a/gcc/fortran/ChangeLog b/gcc/fortran/ChangeLog index 263469a5167..f6dbc36b2b7 100644 --- a/gcc/fortran/ChangeLog +++ b/gcc/fortran/ChangeLog @@ -1,3 +1,21 @@ +2015-04-27 Andre Vehreschild + + 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 PR fortran/60322 diff --git a/gcc/fortran/trans-array.c b/gcc/fortran/trans-array.c index 3803cf82aac..a17f4314d47 100644 --- a/gcc/fortran/trans-array.c +++ b/gcc/fortran/trans-array.c @@ -7523,7 +7523,8 @@ gfc_full_array_size (stmtblock_t *block, tree decl, int rank) static tree 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 size; @@ -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); /* Null the destination if the source is null; otherwise do @@ -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. */ 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, - NULL_TREE); + NULL_TREE, add_when_allocated); } @@ -7635,7 +7638,7 @@ tree gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) { 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. */ @@ -7643,7 +7646,8 @@ gfc_copy_allocatable_data (tree dest, tree src, tree type, int rank) tree 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, tree ctype; tree vref, dref; tree null_cond = NULL_TREE; + tree add_when_allocated; bool called_dealloc_with_status; gfc_init_block (&fnblock); 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)) - 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); - /* 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. */ if (TREE_CODE (decl_type) == ARRAY_TYPE || (GFC_DESCRIPTOR_TYPE_P (decl_type) && rank != 0)) { tmp = gfc_conv_array_data (decl); - var = build_fold_indirect_ref_loc (input_location, - tmp); + var = build_fold_indirect_ref_loc (input_location, tmp); /* Get the number of elements - 1 and set the counter. */ if (GFC_DESCRIPTOR_TYPE_P (decl_type)) @@ -7716,7 +7725,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, else { /* 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); } @@ -7729,19 +7738,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, vref = gfc_build_array_ref (var, index, NULL); - if (purpose == COPY_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) + if (purpose == COPY_ALLOC_COMP || purpose == COPY_ONLY_ALLOC_COMP) { tmp = build_fold_indirect_ref_loc (input_location, gfc_conv_array_data (dest)); @@ -7764,7 +7761,17 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, gfc_add_block_to_block (&fnblock, &loop.pre); 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, build_empty_stmt (input_location)); @@ -8049,6 +8056,22 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, 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)) { tree len, size; @@ -8063,30 +8086,29 @@ structure_alloc_comps (gfc_symbol * der_type, tree decl, TREE_TYPE (len), len, tmp); gfc_add_expr_to_block (&fnblock, tmp); 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, - false, false, size); + false, false, size, NULL_TREE); gfc_add_expr_to_block (&fnblock, tmp); } 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; if (c->attr.codimension) tmp = gfc_copy_allocatable_data (dcmp, comp, ctype, rank); 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); } + 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; default: diff --git a/gcc/fortran/trans-array.h b/gcc/fortran/trans-array.h index 854453490aa..76bad2a199a 100644 --- a/gcc/fortran/trans-array.h +++ b/gcc/fortran/trans-array.h @@ -46,7 +46,7 @@ tree gfc_trans_dealloc_allocated (tree, bool, gfc_expr *); 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); diff --git a/gcc/fortran/trans-expr.c b/gcc/fortran/trans-expr.c index 81b72273e45..9c5ce7d9df0 100644 --- a/gcc/fortran/trans-expr.c +++ b/gcc/fortran/trans-expr.c @@ -6713,13 +6713,13 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_component * cm, { tmp = TREE_TYPE (dest); tmp = gfc_duplicate_allocatable (dest, se.expr, - tmp, expr->rank); + tmp, expr->rank, NULL_TREE); } } else tmp = gfc_duplicate_allocatable (dest, se.expr, TREE_TYPE(cm->backend_decl), - cm->as->rank); + cm->as->rank, NULL_TREE); gfc_add_expr_to_block (&block, tmp); gfc_add_block_to_block (&block, &se.post); diff --git a/gcc/fortran/trans-openmp.c b/gcc/fortran/trans-openmp.c index 9642a7d6b29..dd19a9cec21 100644 --- a/gcc/fortran/trans-openmp.c +++ b/gcc/fortran/trans-openmp.c @@ -391,9 +391,11 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree var, if (GFC_DESCRIPTOR_TYPE_P (ftype) && GFC_TYPE_ARRAY_AKIND (ftype) == GFC_ARRAY_ALLOCATABLE) 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)) - tem = gfc_duplicate_allocatable (destf, declf, ftype, 0); + tem = gfc_duplicate_allocatable (destf, declf, ftype, 0, + NULL_TREE); break; } if (tem) diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 21e4174b5e6..fb5618116d0 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,10 @@ +2015-04-27 Andre Vehreschild + + 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 * gcc.dg/tree-prof/cold_partition_label.c (main): Check for cold diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 new file mode 100644 index 00000000000..df42b342b67 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 @@ -0,0 +1,270 @@ +! { dg-do run } +! +! Check fix for correctly deep copying allocatable components. +! PR fortran/59678 +! Contributed by Andre Vehreschild +! +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 + diff --git a/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_2.f03 b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_2.f03 new file mode 100644 index 00000000000..582a2b8e3e1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_2.f03 @@ -0,0 +1,21 @@ +! { 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 -- 2.30.2