[Fortran,committed] Add testcase for PR 94289

commit c31d2d14f798dc7ca9cc078200d37113749ec3bd
Author: Sandra Loosemore <sandra@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  <jrfsousa@gmail.com>
    	    Sandra Loosemore  <sandra@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