From patchwork Sun Oct 4 13:28:20 2015 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Mikael Morin X-Patchwork-Id: 526147 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 E98A01402B4 for ; Mon, 5 Oct 2015 00:28:42 +1100 (AEDT) Authentication-Results: ozlabs.org; dkim=pass (1024-bit key; unprotected) header.d=gcc.gnu.org header.i=@gcc.gnu.org header.b=mjbv7LI5; 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:from :subject:to:message-id:date:mime-version:content-type; q=dns; s= default; b=CaCeu1yLEPuOqP4e34N1CYuMxybzQjuBongw/xqNyTyg2+aPkVXfa 5c+Y4wTPL9d/Zsk32RYoG1ywj4J/o1KVY3ytCDYDjY+5bP6eT8cdNrO4x9jT/nud goWyH1l6EfF6KH53bfOlHyXDxi04jRhkOw/riGoCH1ujYuOFaD3GJs= 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:from :subject:to:message-id:date:mime-version:content-type; s= default; bh=T8Gq1Hto9bx1Z2NdSRV9m5nHCHU=; b=mjbv7LI5NIvYeVk4vBTh fOUXDO69AKs7vhOHBKGJrJOv8aXbytajizx6mFRAD7eSfMAG7ukI/5a7vmY8XHyD yvfY0p5FJsxbmV4orNPEgee1XcULHig0ClWboh4kPmzKiR346udFjluA9t722J8V wHO5pXf7PIYEzMSDuI2Tipk= Received: (qmail 37191 invoked by alias); 4 Oct 2015 13:28:35 -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 37168 invoked by uid 89); 4 Oct 2015 13:28:33 -0000 Authentication-Results: sourceware.org; auth=none X-Virus-Found: No X-Spam-SWARE-Status: No, score=-1.8 required=5.0 tests=AWL, BAYES_00, KAM_ASCII_DIVIDERS, RCVD_IN_DNSWL_LOW, SPF_PASS, T_RP_MATCHES_RCVD autolearn=ham version=3.3.2 X-Spam-User: qpsmtpd, 2 recipients X-HELO: smtp26.services.sfr.fr Received: from smtp26.services.sfr.fr (HELO smtp26.services.sfr.fr) (93.17.128.163) by sourceware.org (qpsmtpd/0.93/v0.84-503-g423c35a) with (AES256-GCM-SHA384 encrypted) ESMTPS; Sun, 04 Oct 2015 13:28:30 +0000 Received: from filter.sfr.fr (localhost [86.72.15.3]) by msfrf2601.sfr.fr (SMTP Server) with ESMTP id 669771C000811; Sun, 4 Oct 2015 15:28:26 +0200 (CEST) Authentication-Results: sfrmc.priv.atos.fr; dkim=none (no signature); dkim-adsp=none (no policy) header.from=mikael.morin@sfr.fr Received: from [192.168.1.87] (3.15.72.86.rev.sfr.net [86.72.15.3]) (using TLSv1.2 with cipher DHE-RSA-AES128-SHA (128/128 bits)) (No client certificate requested) by msfrf2601.sfr.fr (SMTP Server) with ESMTP id 4CCF21C000416; Sun, 4 Oct 2015 15:28:25 +0200 (CEST) X-SFR-UUID: 20151004132825314.4CCF21C000416@msfrf2601.sfr.fr From: Mikael Morin Subject: [Patch, fortran, 5] Bakport Andre's r222477 deep copy fix for PR67818 To: gcc-patches , gfortran , Andre Vehreschild , "H.J. Lu" Message-ID: <56112974.9010607@sfr.fr> Date: Sun, 4 Oct 2015 15:28:20 +0200 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:38.0) Gecko/20100101 Thunderbird/38.2.0 MIME-Version: 1.0 X-IsSubscribed: yes Hello, my recent PR67721 patch [1] introduced a regression [2] on the 5 branch. [1] https://gcc.gnu.org/ml/gcc-patches/2015-09/msg02048.html [2] https://gcc.gnu.org/bugzilla/show_bug.cgi?id=67818 The patch [1] introduces more deep copies, but deep copies have been somewhat broken, until Andre fixed them on trunk [3][4]. [3] https://gcc.gnu.org/ml/fortran/2015-04/msg00110.html [4] https://gcc.gnu.org/r222477 I'm proposing to backport that fix on the 5 branch. It looks reasonable to me (albeit bigger than I would like), has no known regression so far, and Paul even proposed it for backport at the time he reviewed it [5]. [5] https://gcc.gnu.org/ml/fortran/2015-04/msg00101.html The backported patch exhibits no regression (in either check-fortran or check-target-libgomp) on x86_64-linux, and it fixes the check-target-libgomp regression. The latter has been confirmed by Dominique and H.J.Lu in the PR comments [6][7] [6] https://gcc.gnu.org/bugzilla/show_bug.cgi?id=67818#c7 [7] https://gcc.gnu.org/bugzilla/show_bug.cgi?id=67818#c8 No new test, the failure is already in the libgomp testsuite. OK for the 5 branch? Mikael 2015-10-04 Mikael Morin PR fortran/67721 PR fortran/67818 Backport from mainline r222477: 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-10-04 Mikael Morin PR fortran/67721 PR fortran/67818 Backport from mainline r222477: 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. Index: gcc/fortran/trans-array.c =================================================================== --- gcc/fortran/trans-array.c (révision 228338) +++ gcc/fortran/trans-array.c (copie de travail) @@ -7468,7 +7468,8 @@ gfc_full_array_size (stmtblock_t *block, tree decl 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; @@ -7548,6 +7549,7 @@ duplicate_allocatable (tree dest, tree src, tree t } } + gfc_add_expr_to_block (&block, add_when_allocated); tmp = gfc_finish_block (&block); /* Null the destination if the source is null; otherwise do @@ -7567,10 +7569,11 @@ duplicate_allocatable (tree dest, tree src, tree t /* 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); } @@ -7580,7 +7583,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. */ @@ -7588,7 +7591,8 @@ gfc_copy_allocatable_data (tree dest, tree src, tr 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); } @@ -7620,6 +7624,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree tree ctype; tree vref, dref; tree null_cond = NULL_TREE; + tree add_when_allocated; bool called_dealloc_with_status; gfc_init_block (&fnblock); @@ -7626,21 +7631,25 @@ structure_alloc_comps (gfc_symbol * der_type, tree 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)) @@ -7661,7 +7670,7 @@ structure_alloc_comps (gfc_symbol * der_type, tree 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); } @@ -7674,23 +7683,11 @@ structure_alloc_comps (gfc_symbol * der_type, tree 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); } @@ -7709,7 +7706,17 @@ structure_alloc_comps (gfc_symbol * der_type, tree 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)); @@ -7994,6 +8001,22 @@ structure_alloc_comps (gfc_symbol * der_type, tree 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; @@ -8008,30 +8031,29 @@ structure_alloc_comps (gfc_symbol * der_type, tree 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 (révision 228338) +++ gcc/fortran/trans-array.h (copie de travail) @@ -46,7 +46,7 @@ tree gfc_trans_dealloc_allocated (tree, bool, gfc_ 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-expr.c =================================================================== --- gcc/fortran/trans-expr.c (révision 228339) +++ gcc/fortran/trans-expr.c (copie de travail) @@ -6563,13 +6563,13 @@ gfc_trans_alloc_subarray_assign (tree dest, gfc_co { 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-openmp.c =================================================================== --- gcc/fortran/trans-openmp.c (révision 228338) +++ gcc/fortran/trans-openmp.c (copie de travail) @@ -391,9 +391,11 @@ gfc_walk_alloc_comps (tree decl, tree dest, tree v 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/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 =================================================================== --- gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 (révision 0) +++ gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_1.f03 (copie de travail) @@ -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/gfortran.dg/alloc_comp_deep_copy_2.f03 =================================================================== --- gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_2.f03 (révision 0) +++ gcc/testsuite/gfortran.dg/alloc_comp_deep_copy_2.f03 (copie de travail) @@ -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