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 <san...@codesourcery.com>
Date: Fri Oct 22 11:08:19 2021 -0700
Add testcase for PR fortran/94289
2021-10-22 José Rui Faustino de Sousa <jrfso...@gmail.com>
Sandra Loosemore <san...@codesourcery.com>
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
