From patchwork Mon Nov 29 14:25:52 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 7bit X-Patchwork-Submitter: Chung-Lin Tang X-Patchwork-Id: 48254 Return-Path: X-Original-To: patchwork@sourceware.org Delivered-To: patchwork@sourceware.org Received: from server2.sourceware.org (localhost [IPv6:::1]) by sourceware.org (Postfix) with ESMTP id CDFFE385BC23 for ; Mon, 29 Nov 2021 14:26:26 +0000 (GMT) X-Original-To: gcc-patches@gcc.gnu.org Delivered-To: gcc-patches@gcc.gnu.org Received: from esa4.mentor.iphmx.com (esa4.mentor.iphmx.com [68.232.137.252]) by sourceware.org (Postfix) with ESMTPS id 89A90385840B; Mon, 29 Nov 2021 14:26:09 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 89A90385840B Authentication-Results: sourceware.org; dmarc=none (p=none dis=none) header.from=codesourcery.com Authentication-Results: sourceware.org; spf=pass smtp.mailfrom=mentor.com IronPort-SDR: d59yIWT54OwyKoVMkGZgme+EHZvaXt+F8qBSfZk55s5X1Zukk3C0peTuJngTAM7C+x2iA+K7xE QWLYfDNzXsIW37nYYElP65SRfLo005JozWAJUgimZ3elmH1dHBDYwYnVycJR9rzTi2SfNag//x NQKSLZ3/+5rOQ4XbNu6OqvWD+e8/VBuq8mfW1j54R4xOGc1BnktimqT/rGde86J1ecW7r2szKA AQjLNecOn/LpY+obUgvVup1oUoFfDWDjc1sJLavUoaQDoMXq0daCYCbxSgIvumrWWs5SHngNTi g3haVMAWPo5z7dTNRSNJ4kAP X-IronPort-AV: E=Sophos;i="5.87,273,1631606400"; d="scan'208";a="69033320" Received: from orw-gwy-02-in.mentorg.com ([192.94.38.167]) by esa4.mentor.iphmx.com with ESMTP; 29 Nov 2021 06:26:08 -0800 IronPort-SDR: 1tUo5A9zdzY13F18XKkzw0g8f0VjW3bix2CyvknmLSlHGSI1AGfd3BcZoQCgBjV5cAqAQShHI4 JBUHVR2TSDh9uClcQJB43A39ZE4YequtdwzfJxSkONRclEhACf2lK2fC1nYQkcMnZyk201MZP9 KHFs6sAant0YxCdfRo1QWY/xDlonm6KPPIHIPVqSo0zBqc5g77dlkjuG6wy2RvW4dd7Vt9pZMh abfULB2anzW0TdXxf4eCPUE2V7lQ6Oa3g/4D86bAi+iWWUqLUSCowMCNVY5EOvM4IOr5Ubzcmz z50= Message-ID: Date: Mon, 29 Nov 2021 22:25:52 +0800 MIME-Version: 1.0 User-Agent: Mozilla/5.0 (Macintosh; Intel Mac OS X 10.13; rv:91.0) Gecko/20100101 Thunderbird/91.3.1 Content-Language: en-US To: Fortran List , gcc-patches From: Chung-Lin Tang Subject: [PATCH, Fortran] Fix setting of array lower bound for named arrays X-ClientProxiedBy: svr-orw-mbx-08.mgc.mentorg.com (147.34.90.208) To svr-orw-mbx-02.mgc.mentorg.com (147.34.90.202) X-Spam-Status: No, score=-10.5 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, SPF_HELO_PASS, SPF_PASS, TXREP autolearn=ham autolearn_force=no version=3.4.4 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on server2.sourceware.org X-BeenThere: gcc-patches@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-patches mailing list List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Cc: Tobias Burnus Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" This patch by Tobias, fixes a case of setting array low-bounds, found for particular uses of SOURCE=/MOLD=. For example: program A_M implicit none real, dimension (:), allocatable :: A, B allocate (A(0:5)) call Init (A) contains subroutine Init ( A ) real, dimension ( 0 : ), intent ( in ) :: A integer, dimension ( 1 ) :: lb_B allocate (B, mold = A) ... lb_B = lbound (B, dim=1) ! Error: lb_B assigned 1, instead of 0 like lower-bound of A. Referencing the Fortran standard: "16.9.109 LBOUND (ARRAY [, DIM, KIND])" states: "If DIM is present, ARRAY is a whole array, and either ARRAY is an assumed-size array of rank DIM or dimension DIM of ARRAY has nonzero extent, the result has a value equal to the lower bound for subscript DIM of ARRAY. Otherwise, if DIM is present, the result value is 1." And on what is a "whole array": "9.5.2 Whole arrays" "A whole array is a named array or a structure component ..." The attached patch adjusts the relevant part in gfc_trans_allocate() to only set e3_has_nodescriptor only for non-named arrays. Tobias has tested this once, and I've tested this patch as well on our complete set of testsuites (which usually serves for OpenMP related stuff). Everything appears well with no regressions. Is this okay for trunk? Thanks, Chung-Lin 2021-11-29 Tobias Burnus gcc/fortran/ChangeLog: * trans-stmt.c (gfc_trans_allocate): Set e3_has_nodescriptor to true only for non-named arrays. gcc/testsuite/ChangeLog: * gfortran.dg/allocate_with_source_26.f90: Adjust testcase. * gfortran.dg/allocate_with_mold_4.f90: New testcase. diff --git a/gcc/fortran/trans-stmt.c b/gcc/fortran/trans-stmt.c index bdf7957..982e1e0 100644 --- a/gcc/fortran/trans-stmt.c +++ b/gcc/fortran/trans-stmt.c @@ -6660,16 +6660,13 @@ gfc_trans_allocate (gfc_code * code) else e3rhs = gfc_copy_expr (code->expr3); - // We need to propagate the bounds of the expr3 for source=/mold=; - // however, for nondescriptor arrays, we use internally a lower bound - // of zero instead of one, which needs to be corrected for the allocate obj - if (e3_is == E3_DESC) - { - symbol_attribute attr = gfc_expr_attr (code->expr3); - if (code->expr3->expr_type == EXPR_ARRAY || - (!attr.allocatable && !attr.pointer)) - e3_has_nodescriptor = true; - } + // We need to propagate the bounds of the expr3 for source=/mold=. + // However, for non-named arrays, the lbound has to be 1 and neither the + // bound used inside the called function even when returning an + // allocatable/pointer nor the zero used internally. + if (e3_is == E3_DESC + && code->expr3->expr_type != EXPR_VARIABLE) + e3_has_nodescriptor = true; } /* Loop over all objects to allocate. */ diff --git a/gcc/testsuite/gfortran.dg/allocate_with_mold_4.f90 b/gcc/testsuite/gfortran.dg/allocate_with_mold_4.f90 new file mode 100644 index 0000000..d545fe1 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/allocate_with_mold_4.f90 @@ -0,0 +1,24 @@ +program A_M + implicit none + real, parameter :: C(5:10) = 5.0 + real, dimension (:), allocatable :: A, B + allocate (A(6)) + call Init (A) +contains + subroutine Init ( A ) + real, dimension ( -1 : ), intent ( in ) :: A + integer, dimension ( 1 ) :: lb_B + + allocate (B, mold = A) + if (any (lbound (B) /= lbound (A))) stop 1 + if (any (ubound (B) /= ubound (A))) stop 2 + if (any (shape (B) /= shape (A))) stop 3 + if (size (B) /= size (A)) stop 4 + deallocate (B) + allocate (B, mold = C) + if (any (lbound (B) /= lbound (C))) stop 5 + if (any (ubound (B) /= ubound (C))) stop 6 + if (any (shape (B) /= shape (C))) stop 7 + if (size (B) /= size (C)) stop 8 +end +end diff --git a/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90 b/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90 index 28f24fc..323c8a3 100644 --- a/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90 +++ b/gcc/testsuite/gfortran.dg/allocate_with_source_26.f90 @@ -34,23 +34,23 @@ program p if (lbound(p1, 1) /= 3 .or. ubound(p1, 1) /= 4 & .or. lbound(p2, 1) /= 3 .or. ubound(p2, 1) /= 4 & .or. lbound(p3, 1) /= 1 .or. ubound(p3, 1) /= 2 & - .or. lbound(p4, 1) /= 7 .or. ubound(p4, 1) /= 8 & + .or. lbound(p4, 1) /= 1 .or. ubound(p4, 1) /= 2 & .or. p1(3)%i /= 43 .or. p1(4)%i /= 56 & .or. p2(3)%i /= 43 .or. p2(4)%i /= 56 & .or. p3(1)%i /= 43 .or. p3(2)%i /= 56 & - .or. p4(7)%i /= 11 .or. p4(8)%i /= 12) then + .or. p4(1)%i /= 11 .or. p4(2)%i /= 12) then call abort() endif !write(*,*) lbound(a,1), ubound(a,1) ! prints 1 3 !write(*,*) lbound(b,1), ubound(b,1) ! prints 1 3 - !write(*,*) lbound(c,1), ubound(c,1) ! prints 3 5 + !write(*,*) lbound(c,1), ubound(c,1) ! prints 1 3 !write(*,*) lbound(d,1), ubound(d,1) ! prints 1 5 !write(*,*) lbound(e,1), ubound(e,1) ! prints 1 6 if (lbound(a,1) /= 1 .or. ubound(a,1) /= 3 & .or. lbound(b,1) /= 1 .or. ubound(b,1) /= 3 & - .or. lbound(c,1) /= 3 .or. ubound(c,1) /= 5 & + .or. lbound(c,1) /= 1 .or. ubound(c,1) /= 3 & .or. lbound(d,1) /= 1 .or. ubound(d,1) /= 5 & .or. lbound(e,1) /= 1 .or. ubound(e,1) /= 6) then call abort()