From patchwork Mon Apr 27 17:40:29 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Andre Vehreschild X-Patchwork-Id: 465157 Return-Path: X-Original-To: incoming@patchwork.ozlabs.org Delivered-To: patchwork-incoming@bilbo.ozlabs.org Received: from sourceware.org (server1.sourceware.org [209.132.180.131]) (using TLSv1.2 with cipher ECDHE-RSA-AES256-GCM-SHA384 (256/256 bits)) (No client certificate requested) by ozlabs.org (Postfix) with ESMTPS id F3D1F140082 for ; Tue, 28 Apr 2015 03:40:48 +1000 (AEST) Authentication-Results: ozlabs.org; dkim=pass reason="1024-bit key; unprotected key" header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=fTsiWylD; dkim-adsp=none (unprotected policy); dkim-atps=neutral DomainKey-Signature: a=rsa-sha1; c=nofws; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; q=dns; s=default; b=UoSW8pcvJDbVehX6 WIk/7Wk+1CtRBuip7LBKnhR6qAf2EmeHccMssbNEqPI6lqmvtn5PyDxZ5NQnwmFs UFzxtizxQHCtbiSdWwfau8MHnmZERzqLoUd+dXb2IPnL3t1M28sWGNPaVvgPDqpg LCMfGlXJf+ECznYMMxYhSVaOwNs= DKIM-Signature: v=1; a=rsa-sha1; c=relaxed; d=gcc.gnu.org; h=list-id :list-unsubscribe:list-archive:list-post:list-help:sender:date :from:to:cc:subject:message-id:in-reply-to:references :mime-version:content-type; s=default; bh=A+pmpECTg7D+UVryY1YxLx bkbRc=; b=fTsiWylDUlQ+o9Rp1fxgSHVjw6MVHAdPbpv7VVwjov55uXb1Lp49V+ TI9w8mKmiTmdMWujVXenNY+JXErcB+GZtN84PWc/HN4pl3WHuPNnNvplmgWS+05s YHWyUK80xmmDvDA+YUVGBBvH+PrpROVdeqJnZZaabAMwIQBY/CKeQ= Received: (qmail 116682 invoked by alias); 27 Apr 2015 17:40:38 -0000 Mailing-List: contact gcc-patches-help@gcc.gnu.org; run by ezmlm Precedence: bulk List-Id: List-Unsubscribe: List-Archive: List-Post: List-Help: Sender: gcc-patches-owner@gcc.gnu.org Delivered-To: mailing list gcc-patches@gcc.gnu.org Received: (qmail 116660 invoked by uid 89); 27 Apr 2015 17:40:37 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.3 required=5.0 tests=AWL, BAYES_00, FREEMAIL_FROM, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_NONE, SPF_PASS autolearn=no version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: mout.gmx.net Received: from mout.gmx.net (HELO mout.gmx.net) (212.227.17.20) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Mon, 27 Apr 2015 17:40:34 +0000 Received: from localhost ([88.75.104.20]) by mail.gmx.com (mrgmx102) with ESMTPSA (Nemesis) id 0LjLwB-1ZIYb31Hx9-00dXue; Mon, 27 Apr 2015 19:40:30 +0200 Date: Mon, 27 Apr 2015 19:40:29 +0200 From: Andre Vehreschild To: Paul Richard Thomas Cc: GCC-Patches-ML , GCC-Fortran-ML Subject: Re: [Patch, fortran, pr59678, v1] -- [F03] Segfault on equalizing variables of a complex derived type Message-ID: <20150427194029.5a2bbab9@gmx.de> In-Reply-To: References: <20150418125542.3006a969@gmx.de> MIME-Version: 1.0 X-UI-Out-Filterresults: notjunk:1; Hi Paul, hi all, Paul, thanks for the review. I have integrated all your comments (i) to (iii) and commited as r222477. Regards, Andre On Sat, 25 Apr 2015 16:42:52 +0200 Paul Richard Thomas wrote: > Dear Andre, > > The patch is OK with three changes: > (i) Put the PR line in the testsuite ChangeLog; > (ii) Put the dg-do header information in the testcase, together with > lines to say which PR it fixes and who the contributor is; and > (iii) Add the testcase for PR65841 since your patch for pr65792 breaks > this side-effect fix. > > I will turn my attention to your patch for pr65792 next and try to > figure out why (iii) is necessary. > > Thanks for the patch > > Paul > > > > On 18 April 2015 at 12:55, Andre Vehreschild wrote: > > Hi all, > > > > this patch fixes a deep copy issue, when allocatable components of an entity > > were not allocated. Before the patch the deep copy was run without > > checking if the component is actually allocated and the program crashed > > because a null pointer was dereferenced. Furthermore, was the code to copy > > a structure component not checking the correct ref to determine whether a > > component was allocated, when allocatable components were nested. Example: > > > > type InnerT > > integer, allocatable :: inner_I > > end type > > type T > > type(InnerT), allocatable :: in > > end type > > > > The pseudo pseudo code generated for this was something like: > > > > subroutine copy(src,dst) > > dst = src > > if (allocated (src.in.inner_I)) // crash > > allocate (dst.in) > > end if > > > > dst.in.inner_I = src.in.inner_I // crash > > end subroutine > > > > The patch fixes this by generating: > > > > subroutine copy(src,dst) > > dst = src > > if (allocated (src.in)) > > allocate (dst.in) > > dst.in= src.in > > if (allocated (src.in.inner_I)) > > allocate (dst.in.inner_I) > > dst.in.inner_I = src.in.inner_I > > end > > end > > end subroutine > > > > Of course is this pseudo pseudo code shortened dramatically to show just the > > necessary bits. > > > > Bootstraps and regtests ok on x86_64-linux-gnu/F21. > > > > Ok, for trunk? > > > > Thanks to Dominique for identifying the pr addressed by this patch. > > > > Regards, > > Andre > > -- > > Andre Vehreschild * Email: vehre ad gmx dot de > > > Index: gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_2.f03 =================================================================== --- gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_2.f03 (Revision 0) +++ gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_2.f03 (Revision 222477) @@ -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 Index: gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 =================================================================== --- gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 (Revision 0) +++ gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 (Revision 222477) @@ -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 + Index: gcc/testsuite/ChangeLog =================================================================== --- gcc/testsuite/ChangeLog (Revision 222476) +++ gcc/testsuite/ChangeLog (Revision 222477) @@ -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 Index: gcc/fortran/trans-expr.c =================================================================== --- gcc/fortran/trans-expr.c (Revision 222476) +++ gcc/fortran/trans-expr.c (Revision 222477) @@ -6713,13 +6713,13 @@ { 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); Index: gcc/fortran/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (Revision 222476) +++ gcc/fortran/trans-array.c (Revision 222477) @@ -7523,7 +7523,8 @@ 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 @@ } } + 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 @@ /* 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 @@ 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 @@ 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,6 +7679,7 @@ tree ctype; tree vref, dref; tree null_cond = NULL_TREE; + tree add_when_allocated; bool called_dealloc_with_status; gfc_init_block (&fnblock); @@ -7681,21 +7686,25 @@ 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 @@ 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,23 +7738,11 @@ 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, - gfc_conv_array_data (dest)); - dref = gfc_build_array_ref (tmp, index, NULL); tmp = structure_alloc_comps (der_type, vref, dref, rank, COPY_ALLOC_COMP); } @@ -7764,7 +7761,17 @@ 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 @@ 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 @@ 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: Index: gcc/fortran/trans-array.h =================================================================== --- gcc/fortran/trans-array.h (Revision 222476) +++ gcc/fortran/trans-array.h (Revision 222477) @@ -46,7 +46,7 @@ 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); Index: gcc/fortran/trans-openmp.c =================================================================== --- gcc/fortran/trans-openmp.c (Revision 222476) +++ gcc/fortran/trans-openmp.c (Revision 222477) @@ -391,9 +391,11 @@ 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) Index: gcc/fortran/ChangeLog =================================================================== --- gcc/fortran/ChangeLog (Revision 222476) +++ gcc/fortran/ChangeLog (Revision 222477) @@ -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