gcc/testsuite/gfortran.dg/PR95331.f90

! { dg-do run }
!
! PR fortran/95331
! 

program main_p
  
  implicit none

  integer, parameter :: n = 10
  integer, parameter :: m = 5

  integer, parameter :: b = 3
  integer, parameter :: t = n+b-1
  
  integer, parameter :: l = 4
  integer, parameter :: u = 7
  integer, parameter :: s = 3
  integer, parameter :: e = (u-l)/s+1
  
  call test_f()
  call test_s()
  call test_p()
  call test_a()
  stop

contains

  subroutine test_f()
    integer :: x(n,n)
    integer :: y(b:t)
    integer :: i
    
    x = reshape([(i, i=1,n*n)], [n,n])
    y = x(:,m)
    call sub_s(x(:,m), y, n)
    call sub_s(y, x(:,m), n)
    return
  end subroutine test_f
  
  subroutine test_s()
    integer :: x(n,n)
    integer :: v(e)
    integer :: i
    
    x = reshape([(i, i=1,n*n)], [n,n])
    v = x(l:u:s,m)
    call sub_s(v, v, e)
    call sub_s(x(l:u:s,m), v, e)
    call sub_s(v, x(l:u:s,m), e)
    return
  end subroutine test_s
  
  subroutine test_p()
    integer,  target :: x(n,n)
    integer, pointer :: p(:)
    integer          :: v(e)
    integer          :: i
    
    x = reshape([(i, i=1,n*n)], [n,n])
    v = x(l:u:s,m)
    p => x(:,m)
    call sub_s(p(l:u:s), v, e)
    p => x(l:u:s,m)
    call sub_s(p, v, e)
    p(l:) => x(l:u:s,m)
    call sub_s(p, v, e)
    p(l:l+e-1) => x(l:u:s,m)
    call sub_s(p, v, e)
    allocate(p(n))
    p(:) = x(:,m)
    call sub_s(p(l:u:s), v, e)
    deallocate(p)
    allocate(p(e))
    p(:) = x(l:u:s,m)
    call sub_s(p, v, e)
    deallocate(p)
    allocate(p(l:l+e-1))
    p(:) = x(l:u:s,m)
    call sub_s(p, v, e)
    deallocate(p)
    allocate(p(l:l+e-1))
    p(l:) = x(l:u:s,m)
    call sub_s(p, v, e)
    deallocate(p)
    allocate(p(l:l+e-1))
    p(l:l+e-1) = x(l:u:s,m)
    call sub_s(p, v, e)
    deallocate(p)
    return
  end subroutine test_p
  
  subroutine test_a()
    integer              :: x(n,n)
    integer, allocatable :: a(:)
    integer              :: v(e)
    integer              :: i
    
    x = reshape([(i, i=1,n*n)], [n,n])
    v = x(l:u:s,m)
    a = x(:,m)
    call sub_s(a(l:u:s), v, e)
    deallocate(a)
    allocate(a(n))
    a(:) = x(:,m)
    call sub_s(a(l:u:s), v, e)
    deallocate(a)
    a = x(l:u:s,m)
    call sub_s(a, v, e)
    deallocate(a)
    allocate(a(e))
    a(:) = x(l:u:s,m)
    call sub_s(a, v, e)
    deallocate(a)
    allocate(a(l:l+e-1))
    a(:) = x(l:u:s,m)
    call sub_s(a, v, e)
    deallocate(a)
    allocate(a(l:l+e-1))
    a(l:) = x(l:u:s,m)
    call sub_s(a, v, e)
    deallocate(a)
    allocate(a(l:l+e-1))
    a(l:l+e-1) = x(l:u:s,m)
    call sub_s(a, v, e)
    deallocate(a)
    return
  end subroutine test_a

  subroutine sub_s(a, b, n)
    class(*), intent(in) :: a(:)
    integer,  intent(in) :: b(:)
    integer,  intent(in) :: n

    integer :: i

    if(lbound(a, dim=1)/=1) stop 1001
    if(ubound(a, dim=1)/=n) stop 1002
    if(any(shape(a)/=[n]))  stop 1003
    if(size(a, dim=1)/=n)   stop 1004
    if(size(a)/=size(b))    stop 1005
    do i = 1, n
      call vrfy(a(i), b(i))
    end do
    return
  end subroutine sub_s

  subroutine vrfy(a, b)
    class(*), intent(in) :: a
    integer,  intent(in) :: b

    select type (a)
    type is (integer)
      !print *, a, b
      if(a/=b) stop 2001
    class default
      STOP 2002
    end select
    return
  end subroutine vrfy

end program main_p