! { dg-do run }
!
! This test case is inserted as a check. PR89365 inially asserted that
! gfortran was getting the bounds wrong for allocatable and pointer
! actual arguments. However, the reporter accepted that it is OK and
! this is the corrected version of his testcase, which fills a gap in
! the testsuite.
!
! Contributed by Reinhold Bader <Bader@lrz.de>
!
module mod_ass_rank_inquiry
use, intrinsic :: iso_c_binding
implicit none
logical, parameter :: debug = .true.
integer :: error_count = 0
!
! using inquiry functions for assumed rank objects
!
contains
subroutine foo_1(this)
real(c_float) :: this(..)
select case(rank(this))
case(0)
if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. &
size(ubound(this)) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL shape / lbound / ubound'
end if
if (size(this) /= 1) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL size'
end if
case(1)
if (sum(abs(shape(this) - [4])) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL shape'
end if
if (size(this) /= 4) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL size', size(this)
end if
if (lbound(this,1) /= 1) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL lbound',lbound(this,1)
end if
if (ubound(this,1) /= 4) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL ubound',ubound(this,1)
end if
case(3)
if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL shape'
end if
if (size(this) /= 2*3*4) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL size'
end if
if (sum(abs(lbound(this) - [ 1, 1, 1 ])) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL lbound'
end if
if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL ubound'
end if
case default
error_count = error_count + 1
end select
end subroutine foo_1
subroutine foo_2(this)
real(c_float), allocatable :: this(..)
if (.not. allocated(this)) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL allocated'
end if
select case(rank(this))
case(0)
if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. &
size(ubound(this)) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL shape / lbound / ubound'
end if
if (size(this) /= 1) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL size'
end if
case(1)
if (sum(abs(shape(this) - [4])) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL shape'
end if
if (size(this) /= 4) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL size', size(this)
end if
if (lbound(this,1) /= 2) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL lbound',lbound(this,1)
end if
if (ubound(this,1) /= 5) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL ubound',ubound(this,1)
end if
case(3)
if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL shape'
end if
if (size(this) /= 2*3*4) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL size'
end if
if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL lbound', lbound(this)
end if
if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL ubound', ubound(this)
end if
case default
error_count = error_count + 1
end select
end subroutine foo_2
subroutine foo_3(this)
real(c_float), pointer :: this(..)
if (.not. associated(this)) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL associated'
end if
select case(rank(this))
case(0)
if (size(shape(this)) > 0 .or. size(lbound(this)) > 0 .or. &
size(ubound(this)) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL shape / lbound / ubound'
end if
if (size(this) /= 1) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL size'
end if
case(1)
if (sum(abs(shape(this) - [4])) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL shape'
end if
if (size(this) /= 4) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL size', size(this)
end if
if (lbound(this,1) /= 2) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL lbound',lbound(this,1)
end if
if (ubound(this,1) /= 5) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL ubound',ubound(this,1)
end if
case(3)
if (sum(abs(shape(this) - [ 2, 3, 4 ])) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL shape'
end if
if (size(this) /= 2*3*4) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL size'
end if
if (sum(abs(lbound(this) - [ 0, -1, 1 ])) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL lbound', lbound(this)
end if
if (sum(abs(ubound(this)) - [ 2, 3, 4]) > 0) then
error_count = error_count + 1
if (debug) write(*,*) 'FAIL ubound', ubound(this)
end if
case default
error_count = error_count + 1
end select
end subroutine foo_3
end module mod_ass_rank_inquiry
program ass_rank_inquiry
use mod_ass_rank_inquiry
implicit none
real, allocatable :: x, y(:), z(:,:,:)
real, pointer :: xp, yp(:), zp(:,:,:)
allocate(x, y(2:5), z(0:1,-1:1,1:4))
allocate(xp, yp(2:5), zp(0:1,-1:1,1:4))
call foo_1(x)
if (error_count > 0) write(*,*) 'FAIL: after scalar ',error_count
call foo_1(y)
if (error_count > 0) write(*,*) 'FAIL: after rank-1 ',error_count
call foo_1(z)
if (error_count > 0) write(*,*) 'FAIL: after rank-3 ',error_count
call foo_2(x)
if (error_count > 0) write(*,*) 'FAIL: after allocscalar ',error_count
call foo_2(y)
if (error_count > 0) write(*,*) 'FAIL: after allocrank-1 ',error_count
call foo_2(z)
if (error_count > 0) write(*,*) 'FAIL: after allocrank-3 ',error_count
call foo_3(xp)
if (error_count > 0) write(*,*) 'FAIL: after ptrscalar ',error_count
call foo_3(yp)
if (error_count > 0) write(*,*) 'FAIL: after ptrrank-1 ',error_count
call foo_3(zp)
if (error_count > 0) write(*,*) 'FAIL: after ptrrank-3 ',error_count
if (error_count == 0) then
write(*,*) 'OK'
else
stop 1
end if
deallocate(x, y, z)
deallocate(xp, yp, zp)
end program ass_rank_inquiry