gcc/testsuite/gfortran.dg/PR95331.f90

   1 ! { dg-do run }
   2 !
   3 ! PR fortran/95331
   4 !
   5
   6 program main_p
   7
   8   implicit none
   9
  10   integer, parameter :: n = 10
  11   integer, parameter :: m = 5
  12
  13   integer, parameter :: b = 3
  14   integer, parameter :: t = n+b-1
  15
  16   integer, parameter :: l = 4
  17   integer, parameter :: u = 7
  18   integer, parameter :: s = 3
  19   integer, parameter :: e = (u-l)/s+1
  20
  21   call test_f()
  22   call test_s()
  23   call test_p()
  24   call test_a()
  25   stop
  26
  27 contains
  28
  29   subroutine test_f()
  30     integer :: x(n,n)
  31     integer :: y(b:t)
  32     integer :: i
  33
  34     x = reshape([(i, i=1,n*n)], [n,n])
  35     y = x(:,m)
  36     call sub_s(x(:,m), y, n)
  37     call sub_s(y, x(:,m), n)
  38     return
  39   end subroutine test_f
  40
  41   subroutine test_s()
  42     integer :: x(n,n)
  43     integer :: v(e)
  44     integer :: i
  45
  46     x = reshape([(i, i=1,n*n)], [n,n])
  47     v = x(l:u:s,m)
  48     call sub_s(v, v, e)
  49     call sub_s(x(l:u:s,m), v, e)
  50     call sub_s(v, x(l:u:s,m), e)
  51     return
  52   end subroutine test_s
  53
  54   subroutine test_p()
  55     integer,  target :: x(n,n)
  56     integer, pointer :: p(:)
  57     integer          :: v(e)
  58     integer          :: i
  59
  60     x = reshape([(i, i=1,n*n)], [n,n])
  61     v = x(l:u:s,m)
  62     p => x(:,m)
  63     call sub_s(p(l:u:s), v, e)
  64     p => x(l:u:s,m)
  65     call sub_s(p, v, e)
  66     p(l:) => x(l:u:s,m)
  67     call sub_s(p, v, e)
  68     p(l:l+e-1) => x(l:u:s,m)
  69     call sub_s(p, v, e)
  70     allocate(p(n))
  71     p(:) = x(:,m)
  72     call sub_s(p(l:u:s), v, e)
  73     deallocate(p)
  74     allocate(p(e))
  75     p(:) = x(l:u:s,m)
  76     call sub_s(p, v, e)
  77     deallocate(p)
  78     allocate(p(l:l+e-1))
  79     p(:) = x(l:u:s,m)
  80     call sub_s(p, v, e)
  81     deallocate(p)
  82     allocate(p(l:l+e-1))
  83     p(l:) = x(l:u:s,m)
  84     call sub_s(p, v, e)
  85     deallocate(p)
  86     allocate(p(l:l+e-1))
  87     p(l:l+e-1) = x(l:u:s,m)
  88     call sub_s(p, v, e)
  89     deallocate(p)
  90     return
  91   end subroutine test_p
  92
  93   subroutine test_a()
  94     integer              :: x(n,n)
  95     integer, allocatable :: a(:)
  96     integer              :: v(e)
  97     integer              :: i
  98
  99     x = reshape([(i, i=1,n*n)], [n,n])
 100     v = x(l:u:s,m)
 101     a = x(:,m)
 102     call sub_s(a(l:u:s), v, e)
 103     deallocate(a)
 104     allocate(a(n))
 105     a(:) = x(:,m)
 106     call sub_s(a(l:u:s), v, e)
 107     deallocate(a)
 108     a = x(l:u:s,m)
 109     call sub_s(a, v, e)
 110     deallocate(a)
 111     allocate(a(e))
 112     a(:) = x(l:u:s,m)
 113     call sub_s(a, v, e)
 114     deallocate(a)
 115     allocate(a(l:l+e-1))
 116     a(:) = x(l:u:s,m)
 117     call sub_s(a, v, e)
 118     deallocate(a)
 119     allocate(a(l:l+e-1))
 120     a(l:) = x(l:u:s,m)
 121     call sub_s(a, v, e)
 122     deallocate(a)
 123     allocate(a(l:l+e-1))
 124     a(l:l+e-1) = x(l:u:s,m)
 125     call sub_s(a, v, e)
 126     deallocate(a)
 127     return
 128   end subroutine test_a
 129
 130   subroutine sub_s(a, b, n)
 131     class(*), intent(in) :: a(:)
 132     integer,  intent(in) :: b(:)
 133     integer,  intent(in) :: n
 134
 135     integer :: i
 136
 137     if(lbound(a, dim=1)/=1) stop 1001
 138     if(ubound(a, dim=1)/=n) stop 1002
 139     if(any(shape(a)/=[n]))  stop 1003
 140     if(size(a, dim=1)/=n)   stop 1004
 141     if(size(a)/=size(b))    stop 1005
 142     do i = 1, n
 143       call vrfy(a(i), b(i))
 144     end do
 145     return
 146   end subroutine sub_s
 147
 148   subroutine vrfy(a, b)
 149     class(*), intent(in) :: a
 150     integer,  intent(in) :: b
 151
 152     select type (a)
 153     type is (integer)
 154       !print *, a, b
 155       if(a/=b) stop 2001
 156     class default
 157       STOP 2002
 158     end select
 159     return
 160   end subroutine vrfy
 161
 162 end program main_p
 163