! { 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" } }