From patchwork Fri Oct 22 18:19:26 2021 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: Sandra Loosemore X-Patchwork-Id: 46536 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 454A03857C7F for ; Fri, 22 Oct 2021 18:20:00 +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 31E813858416; Fri, 22 Oct 2021 18:19:35 +0000 (GMT) DMARC-Filter: OpenDMARC Filter v1.4.1 sourceware.org 31E813858416 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: rQn1uJKc6K7hEzp8YOy4T5T/wZOwN9xah5ddWOPtEFLoIhhAANg0L4/ZIVXJ5HpibnHsqlHnT6 ZGGYvByaoJGO74rVU2m9fkvaisPu1e4ZXnmZWnwLZec4DLpoZTdQCO4e3aL74r6vUs/hcYFB6i XqKpMwDd8fW9FHTZ7h/jbKwAwlZTLbFhSeFIOyywBkGNd7OzQi2Ooo+iBJr7L3+KpfAi8+QqGj 3C61HVRGE+uUbEyCKlEFG1fs9frV4iyup6AnlwyZXegDaHEpNfC7gt4obfZPc3YI2Vfpi2WhHD W+hj5tcRP0bCMZZOctCUzJVt X-IronPort-AV: E=Sophos;i="5.87,173,1631606400"; d="scan'208";a="67536631" Received: from orw-gwy-01-in.mentorg.com ([192.94.38.165]) by esa4.mentor.iphmx.com with ESMTP; 22 Oct 2021 10:19:33 -0800 IronPort-SDR: PfCLUh8W9GDQbNVy7FhfOIEPw+IYrqtKIs0KRuaxpN37RyDfLTE7UgmbHaqDQDWFogs7+T2VF6 chJSTKT7suVLXDwdC66tfY+GAMOCJqLLo4aHs7vB+jyN/lVubRwwUWcAomwtWkbuVnc2ok6rTp hSVMqSckmbkCqJsEUCD3swzj6HBcbiMOUmWtDXZvVZnNJutjavW9EDFjstO8jn84G5yGdUPVYg wP1tQjaLP+rp8oEbooFtacNUh+9VV2CKlLzYR0Wi+luI/7rqkTIdBztpIUqSsgO4YKWxQCZS8k i+4= To: "fortran@gcc.gnu.org" , "gcc-patches@gcc.gnu.org" From: Sandra Loosemore Subject: [Fortran, committed] Add testcase for PR 94289 Message-ID: <7b717177-2555-7c34-a22d-10899d467be4@codesourcery.com> Date: Fri, 22 Oct 2021 12:19:26 -0600 User-Agent: Mozilla/5.0 (X11; Linux x86_64; rv:78.0) Gecko/20100101 Thunderbird/78.13.0 MIME-Version: 1.0 Content-Language: en-US X-ClientProxiedBy: SVR-ORW-MBX-05.mgc.mentorg.com (147.34.90.205) To svr-orw-mbx-03.mgc.mentorg.com (147.34.90.203) X-Spam-Status: No, score=-9.6 required=5.0 tests=BAYES_00, GIT_PATCH_0, HEADER_FROM_DIFFERENT_DOMAINS, KAM_DMARC_STATUS, KAM_NUMSUBJECT, 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: , Errors-To: gcc-patches-bounces+patchwork=sourceware.org@gcc.gnu.org Sender: "Gcc-patches" I've committed this slightly cleaned-up version of the testcase originally submitted with the now-fixed issue PR 94289. -Sandra commit c31d2d14f798dc7ca9cc078200d37113749ec3bd Author: Sandra Loosemore Date: Fri Oct 22 11:08:19 2021 -0700 Add testcase for PR fortran/94289 2021-10-22 José Rui Faustino de Sousa Sandra Loosemore gcc/testsuite/ PR fortran/94289 * gfortran.dg/PR94289.f90: New. diff --git a/gcc/testsuite/gfortran.dg/PR94289.f90 b/gcc/testsuite/gfortran.dg/PR94289.f90 new file mode 100644 index 0000000..4f17d97 --- /dev/null +++ b/gcc/testsuite/gfortran.dg/PR94289.f90 @@ -0,0 +1,168 @@ +! { dg-do run } +! +! Testcase for PR 94289 +! +! - if the dummy argument is a pointer/allocatable, it has the same +! bounds as the dummy argument +! - if is is nonallocatable nonpointer, the lower bounds are [1, 1, 1]. + +module bounds_m + + implicit none + + private + public :: & + lb, ub + + public :: & + bnds_p, & + bnds_a, & + bnds_e + + integer, parameter :: lb1 = 3 + integer, parameter :: lb2 = 5 + integer, parameter :: lb3 = 9 + integer, parameter :: ub1 = 4 + integer, parameter :: ub2 = 50 + integer, parameter :: ub3 = 11 + integer, parameter :: ex1 = ub1 - lb1 + 1 + integer, parameter :: ex2 = ub2 - lb2 + 1 + integer, parameter :: ex3 = ub3 - lb3 + 1 + + integer, parameter :: lf(*) = [1,1,1] + integer, parameter :: lb(*) = [lb1,lb2,lb3] + integer, parameter :: ub(*) = [ub1,ub2,ub3] + integer, parameter :: ex(*) = [ex1,ex2,ex3] + +contains + + subroutine bounds(a, lb, ub) + integer, pointer, intent(in) :: a(..) + integer, intent(in) :: lb(3) + integer, intent(in) :: ub(3) + + integer :: ex(3) + + ex = max(ub-lb+1, 0) + if(any(lbound(a)/=lb)) stop 101 + if(any(ubound(a)/=ub)) stop 102 + if(any( shape(a)/=ex)) stop 103 + return + end subroutine bounds + + subroutine bnds_p(this) + integer, pointer, intent(in) :: this(..) + + if(any(lbound(this)/=lb)) stop 1 + if(any(ubound(this)/=ub)) stop 2 + if(any( shape(this)/=ex)) stop 3 + call bounds(this, lb, ub) + return + end subroutine bnds_p + + subroutine bnds_a(this) + integer, allocatable, target, intent(in) :: this(..) + + if(any(lbound(this)/=lb)) stop 4 + if(any(ubound(this)/=ub)) stop 5 + if(any( shape(this)/=ex)) stop 6 + call bounds(this, lb, ub) + return + end subroutine bnds_a + + subroutine bnds_e(this) + integer, target, intent(in) :: this(..) + + if(any(lbound(this)/=lf)) stop 7 + if(any(ubound(this)/=ex)) stop 8 + if(any( shape(this)/=ex)) stop 9 + call bounds(this, lf, ex) + return + end subroutine bnds_e + +end module bounds_m + +program bounds_p + + use, intrinsic :: iso_c_binding, only: c_int + + use bounds_m + + implicit none + + integer, parameter :: fpn = 1 + integer, parameter :: fan = 2 + integer, parameter :: fon = 3 + + integer :: i + + do i = fpn, fon + call test_p(i) + end do + do i = fpn, fon + call test_a(i) + end do + do i = fpn, fon + call test_e(i) + end do + stop + +contains + + subroutine test_p(t) + integer, intent(in) :: t + + integer, pointer :: a(:,:,:) + + allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))) + select case(t) + case(fpn) + call bnds_p(a) + case(fan) + case(fon) + call bnds_e(a) + case default + stop + end select + deallocate(a) + return + end subroutine test_p + + subroutine test_a(t) + integer, intent(in) :: t + + integer, allocatable, target :: a(:,:,:) + + allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))) + select case(t) + case(fpn) + call bnds_p(a) + case(fan) + call bnds_a(a) + case(fon) + call bnds_e(a) + case default + stop + end select + deallocate(a) + return + end subroutine test_a + + subroutine test_e(t) + integer, intent(in) :: t + + integer, target :: a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)) + + select case(t) + case(fpn) + call bnds_p(a) + case(fan) + case(fon) + call bnds_e(a) + case default + stop + end select + return + end subroutine test_e + +end program bounds_p