gcc/testsuite/gfortran.dg/PR93963.f90

! { dg-do run }
! { dg-additional-options "-fdump-tree-original" }
!
! Test the fix for PR93963
!

module m
contains
function rank_p(this) result(rnk) bind(c)
  use, intrinsic :: iso_c_binding, only: c_int

  implicit none
  
  integer(kind=c_int), pointer, intent(in) :: this(..)
  integer(kind=c_int)                      :: rnk

  select rank(this)
  rank(0)
    rnk = 0
  rank(1)
    rnk = 1
  rank(2)
    rnk = 2
  rank(3)
    rnk = 3
  rank(4)
    rnk = 4
  rank(5)
    rnk = 5
  rank(6)
    rnk = 6
  rank(7)
    rnk = 7
  rank(8)
    rnk = 8
  rank(9)
    rnk = 9
  rank(10)
    rnk = 10
  rank(11)
    rnk = 11
  rank(12)
    rnk = 12
  rank(13)
    rnk = 13
  rank(14)
    rnk = 14
  rank(15)
    rnk = 15
  rank default
    rnk = -1000
  end select
  return
end function rank_p

function rank_a(this) result(rnk) bind(c)
  use, intrinsic :: iso_c_binding, only: c_int

  implicit none
  
  integer(kind=c_int), allocatable, intent(in) :: this(..)
  integer(kind=c_int)                          :: rnk

  select rank(this)
  rank(0)
    rnk = 0
  rank(1)
    rnk = 1
  rank(2)
    rnk = 2
  rank(3)
    rnk = 3
  rank(4)
    rnk = 4
  rank(5)
    rnk = 5
  rank(6)
    rnk = 6
  rank(7)
    rnk = 7
  rank(8)
    rnk = 8
  rank(9)
    rnk = 9
  rank(10)
    rnk = 10
  rank(11)
    rnk = 11
  rank(12)
    rnk = 12
  rank(13)
    rnk = 13
  rank(14)
    rnk = 14
  rank(15)
    rnk = 15
  rank default
    rnk = -1000
  end select
  return
end function rank_a

function rank_o(this) result(rnk) bind(c)
  use, intrinsic :: iso_c_binding, only: c_int

  implicit none
  
  integer(kind=c_int), intent(in) :: this(..)
  integer(kind=c_int)             :: rnk

  select rank(this)
  rank(0)
    rnk = 0
  rank(1)
    rnk = 1
  rank(2)
    rnk = 2
  rank(3)
    rnk = 3
  rank(4)
    rnk = 4
  rank(5)
    rnk = 5
  rank(6)
    rnk = 6
  rank(7)
    rnk = 7
  rank(8)
    rnk = 8
  rank(9)
    rnk = 9
  rank(10)
    rnk = 10
  rank(11)
    rnk = 11
  rank(12)
    rnk = 12
  rank(13)
    rnk = 13
  rank(14)
    rnk = 14
  rank(15)
    rnk = 15
  rank default
    rnk = -1000
  end select
  return
end function rank_o

end module m

program selr_p
  use m
  use, intrinsic :: iso_c_binding, only: c_int

  implicit none

  integer(kind=c_int), parameter :: siz = 7
  integer(kind=c_int), parameter :: rnk = 1

  integer(kind=c_int),     pointer :: intp(:)
  integer(kind=c_int), allocatable :: inta(:)
  integer(kind=c_int)              :: irnk

  nullify(intp)
  irnk = rank_p(intp)
  if (irnk /= rnk)        stop 1
  if (irnk /= rank(intp)) stop 2
  !
  irnk = rank_a(inta)
  if (irnk /= rnk)        stop 3
  if (irnk /= rank(inta)) stop 4
  !
  allocate(intp(siz))
  irnk = rank_p(intp)
  if (irnk /= rnk)        stop 5
  if (irnk /= rank(intp)) stop 6
  irnk = rank_o(intp)
  if (irnk /= rnk)        stop 7
  if (irnk /= rank(intp)) stop 8
  deallocate(intp)
  nullify(intp)
  !
  allocate(inta(siz))
  irnk = rank_a(inta)
  if (irnk /= rnk)        stop 9
  if (irnk /= rank(inta)) stop 10
  irnk = rank_o(inta)
  if (irnk /= rnk)        stop 11
  if (irnk /= rank(inta)) stop 12
  deallocate(inta)

end program selr_p

! Special code for assumed rank - but only if not allocatable/pointer
! Thus, expect it only once for subroutine rank_o but not for rank_a or rank_p
! { dg-final { scan-tree-dump-times "ubound != -1" 1 "original" } }