gcc/testsuite/gfortran.dg/PR93963.f90

   1 ! { dg-do run }
   2 ! { dg-additional-options "-fdump-tree-original" }
   3 !
   4 ! Test the fix for PR93963
   5 !
   6
   7 module m
   8 contains
   9 function rank_p(this) result(rnk) bind(c)
  10   use, intrinsic :: iso_c_binding, only: c_int
  11
  12   implicit none
  13
  14   integer(kind=c_int), pointer, intent(in) :: this(..)
  15   integer(kind=c_int)                      :: rnk
  16
  17   select rank(this)
  18   rank(0)
  19     rnk = 0
  20   rank(1)
  21     rnk = 1
  22   rank(2)
  23     rnk = 2
  24   rank(3)
  25     rnk = 3
  26   rank(4)
  27     rnk = 4
  28   rank(5)
  29     rnk = 5
  30   rank(6)
  31     rnk = 6
  32   rank(7)
  33     rnk = 7
  34   rank(8)
  35     rnk = 8
  36   rank(9)
  37     rnk = 9
  38   rank(10)
  39     rnk = 10
  40   rank(11)
  41     rnk = 11
  42   rank(12)
  43     rnk = 12
  44   rank(13)
  45     rnk = 13
  46   rank(14)
  47     rnk = 14
  48   rank(15)
  49     rnk = 15
  50   rank default
  51     rnk = -1000
  52   end select
  53   return
  54 end function rank_p
  55
  56 function rank_a(this) result(rnk) bind(c)
  57   use, intrinsic :: iso_c_binding, only: c_int
  58
  59   implicit none
  60
  61   integer(kind=c_int), allocatable, intent(in) :: this(..)
  62   integer(kind=c_int)                          :: rnk
  63
  64   select rank(this)
  65   rank(0)
  66     rnk = 0
  67   rank(1)
  68     rnk = 1
  69   rank(2)
  70     rnk = 2
  71   rank(3)
  72     rnk = 3
  73   rank(4)
  74     rnk = 4
  75   rank(5)
  76     rnk = 5
  77   rank(6)
  78     rnk = 6
  79   rank(7)
  80     rnk = 7
  81   rank(8)
  82     rnk = 8
  83   rank(9)
  84     rnk = 9
  85   rank(10)
  86     rnk = 10
  87   rank(11)
  88     rnk = 11
  89   rank(12)
  90     rnk = 12
  91   rank(13)
  92     rnk = 13
  93   rank(14)
  94     rnk = 14
  95   rank(15)
  96     rnk = 15
  97   rank default
  98     rnk = -1000
  99   end select
 100   return
 101 end function rank_a
 102
 103 function rank_o(this) result(rnk) bind(c)
 104   use, intrinsic :: iso_c_binding, only: c_int
 105
 106   implicit none
 107
 108   integer(kind=c_int), intent(in) :: this(..)
 109   integer(kind=c_int)             :: rnk
 110
 111   select rank(this)
 112   rank(0)
 113     rnk = 0
 114   rank(1)
 115     rnk = 1
 116   rank(2)
 117     rnk = 2
 118   rank(3)
 119     rnk = 3
 120   rank(4)
 121     rnk = 4
 122   rank(5)
 123     rnk = 5
 124   rank(6)
 125     rnk = 6
 126   rank(7)
 127     rnk = 7
 128   rank(8)
 129     rnk = 8
 130   rank(9)
 131     rnk = 9
 132   rank(10)
 133     rnk = 10
 134   rank(11)
 135     rnk = 11
 136   rank(12)
 137     rnk = 12
 138   rank(13)
 139     rnk = 13
 140   rank(14)
 141     rnk = 14
 142   rank(15)
 143     rnk = 15
 144   rank default
 145     rnk = -1000
 146   end select
 147   return
 148 end function rank_o
 149
 150 end module m
 151
 152 program selr_p
 153   use m
 154   use, intrinsic :: iso_c_binding, only: c_int
 155
 156   implicit none
 157
 158   integer(kind=c_int), parameter :: siz = 7
 159   integer(kind=c_int), parameter :: rnk = 1
 160
 161   integer(kind=c_int),     pointer :: intp(:)
 162   integer(kind=c_int), allocatable :: inta(:)
 163   integer(kind=c_int)              :: irnk
 164
 165   nullify(intp)
 166   irnk = rank_p(intp)
 167   if (irnk /= rnk)        stop 1
 168   if (irnk /= rank(intp)) stop 2
 169   !
 170   irnk = rank_a(inta)
 171   if (irnk /= rnk)        stop 3
 172   if (irnk /= rank(inta)) stop 4
 173   !
 174   allocate(intp(siz))
 175   irnk = rank_p(intp)
 176   if (irnk /= rnk)        stop 5
 177   if (irnk /= rank(intp)) stop 6
 178   irnk = rank_o(intp)
 179   if (irnk /= rnk)        stop 7
 180   if (irnk /= rank(intp)) stop 8
 181   deallocate(intp)
 182   nullify(intp)
 183   !
 184   allocate(inta(siz))
 185   irnk = rank_a(inta)
 186   if (irnk /= rnk)        stop 9
 187   if (irnk /= rank(inta)) stop 10
 188   irnk = rank_o(inta)
 189   if (irnk /= rnk)        stop 11
 190   if (irnk /= rank(inta)) stop 12
 191   deallocate(inta)
 192
 193 end program selr_p
 194
 195 ! Special code for assumed rank - but only if not allocatable/pointer
 196 ! Thus, expect it only once for subroutine rank_o but not for rank_a or rank_p
 197 ! { dg-final { scan-tree-dump-times "ubound != -1" 1 "original" } }