OpenE2K/gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Add testcase for PR fortran/94289

Browse Source 
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.
This commit is contained in:
Sandra Loosemore 2021-10-22 11:08:19 -07:00
parent b7cb6d66bd
commit c31d2d14f7
1 changed files with 168 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

168
gcc/testsuite/gfortran.dg/PR94289.f90 Normal file
View File

@ -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