1! { dg-do run } 2! { dg-additional-options "-fdump-tree-original" } 3! 4! Test the fix for PR93963 5! 6 7module m 8contains 9function 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 54end function rank_p 55 56function 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 101end function rank_a 102 103function 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 148end function rank_o 149 150end module m 151 152program 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 193end 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" } } 198