gcc/testsuite/gfortran.dg/PR94289.f90

   1 ! { dg-do run }
   2 !
   3 ! Testcase for PR 94289
   4 !
   5 ! - if the dummy argument is a pointer/allocatable, it has the same
   6 !   bounds as the dummy argument
   7 ! - if is is nonallocatable nonpointer, the lower bounds are [1, 1, 1].
   8
   9 module bounds_m
  10
  11   implicit none
  12
  13   private
  14   public :: &
  15     lb, ub
  16
  17   public :: &
  18     bnds_p, &
  19     bnds_a, &
  20     bnds_e
  21
  22   integer, parameter :: lb1 = 3
  23   integer, parameter :: lb2 = 5
  24   integer, parameter :: lb3 = 9
  25   integer, parameter :: ub1 = 4
  26   integer, parameter :: ub2 = 50
  27   integer, parameter :: ub3 = 11
  28   integer, parameter :: ex1 = ub1 - lb1 + 1
  29   integer, parameter :: ex2 = ub2 - lb2 + 1
  30   integer, parameter :: ex3 = ub3 - lb3 + 1
  31
  32   integer, parameter :: lf(*) = [1,1,1]
  33   integer, parameter :: lb(*) = [lb1,lb2,lb3]
  34   integer, parameter :: ub(*) = [ub1,ub2,ub3]
  35   integer, parameter :: ex(*) = [ex1,ex2,ex3]
  36
  37 contains
  38
  39   subroutine bounds(a, lb, ub)
  40     integer, pointer, intent(in) :: a(..)
  41     integer,          intent(in) :: lb(3)
  42     integer,          intent(in) :: ub(3)
  43
  44     integer :: ex(3)
  45
  46     ex = max(ub-lb+1, 0)
  47     if(any(lbound(a)/=lb)) stop 101
  48     if(any(ubound(a)/=ub)) stop 102
  49     if(any( shape(a)/=ex)) stop 103
  50     return
  51   end subroutine bounds
  52
  53   subroutine bnds_p(this)
  54     integer, pointer, intent(in) :: this(..)
  55
  56     if(any(lbound(this)/=lb)) stop 1
  57     if(any(ubound(this)/=ub)) stop 2
  58     if(any( shape(this)/=ex)) stop 3
  59     call bounds(this, lb, ub)
  60     return
  61   end subroutine bnds_p
  62
  63   subroutine bnds_a(this)
  64     integer, allocatable, target, intent(in) :: this(..)
  65
  66     if(any(lbound(this)/=lb)) stop 4
  67     if(any(ubound(this)/=ub)) stop 5
  68     if(any( shape(this)/=ex)) stop 6
  69     call bounds(this, lb, ub)
  70     return
  71   end subroutine bnds_a
  72
  73   subroutine bnds_e(this)
  74     integer, target, intent(in) :: this(..)
  75
  76     if(any(lbound(this)/=lf)) stop 7
  77     if(any(ubound(this)/=ex)) stop 8
  78     if(any( shape(this)/=ex)) stop 9
  79     call bounds(this, lf, ex)
  80     return
  81   end subroutine bnds_e
  82
  83 end module bounds_m
  84
  85 program bounds_p
  86
  87   use, intrinsic :: iso_c_binding, only: c_int
  88
  89   use bounds_m
  90
  91   implicit none
  92
  93   integer, parameter :: fpn = 1
  94   integer, parameter :: fan = 2
  95   integer, parameter :: fon = 3
  96
  97   integer :: i
  98
  99   do i = fpn, fon
 100     call test_p(i)
 101   end do
 102   do i = fpn, fon
 103     call test_a(i)
 104   end do
 105   do i = fpn, fon
 106     call test_e(i)
 107   end do
 108   stop
 109
 110 contains
 111
 112   subroutine test_p(t)
 113     integer, intent(in) :: t
 114
 115     integer, pointer :: a(:,:,:)
 116
 117     allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)))
 118     select case(t)
 119     case(fpn)
 120       call bnds_p(a)
 121     case(fan)
 122     case(fon)
 123       call bnds_e(a)
 124     case default
 125       stop
 126     end select
 127     deallocate(a)
 128     return
 129   end subroutine test_p
 130
 131   subroutine test_a(t)
 132     integer, intent(in) :: t
 133
 134     integer, allocatable, target :: a(:,:,:)
 135
 136     allocate(a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3)))
 137     select case(t)
 138     case(fpn)
 139       call bnds_p(a)
 140     case(fan)
 141       call bnds_a(a)
 142     case(fon)
 143       call bnds_e(a)
 144     case default
 145       stop
 146     end select
 147     deallocate(a)
 148     return
 149   end subroutine test_a
 150
 151   subroutine test_e(t)
 152     integer, intent(in) :: t
 153
 154     integer, target :: a(lb(1):ub(1),lb(2):ub(2),lb(3):ub(3))
 155
 156     select case(t)
 157     case(fpn)
 158       call bnds_p(a)
 159     case(fan)
 160     case(fon)
 161       call bnds_e(a)
 162     case default
 163       stop
 164     end select
 165     return
 166   end subroutine test_e
 167
 168 end program bounds_p