1! { dg-do run } 2! 3! PR fortran/99171 4! 5! Check dummy procedure arguments, especially optional ones 6! 7module m 8 use iso_c_binding 9 implicit none (type, external) 10 integer :: cnt 11 integer :: cnt2 12contains 13 subroutine proc() 14 cnt = cnt + 1 15 end subroutine 16 17 subroutine proc2() 18 cnt2 = cnt2 + 1 19 end subroutine 20 21 subroutine check(my_proc) 22 procedure(proc) :: my_proc 23 cnt = 42 24 call my_proc() 25 if (cnt /= 43) stop 1 26 27 !$omp parallel 28 call my_proc() 29 !$omp end parallel 30 if (cnt <= 43) stop 2 31 end 32 33 subroutine check_opt(my_proc) 34 procedure(proc), optional :: my_proc 35 logical :: is_present 36 is_present = present(my_proc) 37 cnt = 55 38 if (present (my_proc)) then 39 call my_proc() 40 if (cnt /= 56) stop 3 41 endif 42 43 !$omp parallel 44 if (is_present .neqv. present (my_proc)) stop 4 45 if (present (my_proc)) then 46 call my_proc() 47 if (cnt <= 56) stop 5 48 end if 49 !$omp end parallel 50 if (is_present) then 51 if (cnt <= 56) stop 6 52 else if (cnt /= 55) then 53 stop 7 54 end if 55 end 56 57 subroutine check_ptr(my_proc) 58 procedure(proc), pointer :: my_proc 59 logical :: is_assoc 60 integer :: mycnt 61 is_assoc = associated (my_proc) 62 63 cnt = 10 64 cnt2 = 20 65 if (associated (my_proc)) then 66 call my_proc() 67 if (cnt /= 11 .or. cnt2 /= 20) stop 8 68 endif 69 70 !$omp parallel 71 if (is_assoc .neqv. associated (my_proc)) stop 9 72 if (associated (my_proc)) then 73 if (.not. associated (my_proc, proc)) stop 10 74 call my_proc() 75 if (cnt <= 11 .or. cnt2 /= 20) stop 11 76 else if (cnt /= 10 .or. cnt2 /= 20) then 77 stop 12 78 end if 79 !$omp end parallel 80 if (is_assoc .neqv. associated (my_proc)) stop 13 81 if (associated (my_proc)) then 82 if (cnt <= 11 .or. cnt2 /= 20) stop 14 83 else if (is_assoc .and. (cnt /= 11 .or. cnt2 /= 20)) then 84 stop 15 85 end if 86 87 cnt = 30 88 cnt2 = 40 89 mycnt = 0 90 !$omp parallel shared(mycnt) 91 !$omp critical 92 my_proc => proc2 93 if (.not.associated (my_proc, proc2)) stop 17 94 mycnt = mycnt + 1 95 call my_proc() 96 if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 18 97 !$omp end critical 98 !$omp end parallel 99 if (.not.associated (my_proc, proc2)) stop 19 100 if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 20 101 end 102 103 subroutine check_ptr_opt(my_proc) 104 procedure(proc), pointer, optional :: my_proc 105 logical :: is_assoc, is_present 106 integer :: mycnt 107 is_assoc = .false. 108 is_present = present(my_proc) 109 110 cnt = 10 111 cnt2 = 20 112 if (present (my_proc)) then 113 is_assoc = associated (my_proc) 114 if (associated (my_proc)) then 115 call my_proc() 116 if (cnt /= 11 .or. cnt2 /= 20) stop 21 117 endif 118 end if 119 120 !$omp parallel 121 if (is_present .neqv. present (my_proc)) stop 22 122 if (present (my_proc)) then 123 if (is_assoc .neqv. associated (my_proc)) stop 23 124 if (associated (my_proc)) then 125 if (.not. associated (my_proc, proc)) stop 24 126 call my_proc() 127 if (cnt <= 11 .or. cnt2 /= 20) stop 25 128 else if (cnt /= 10 .or. cnt2 /= 20) then 129 stop 26 130 end if 131 end if 132 !$omp end parallel 133 if (present (my_proc)) then 134 if (is_assoc .neqv. associated (my_proc)) stop 27 135 if (associated (my_proc)) then 136 if (cnt <= 11 .or. cnt2 /= 20) stop 28 137 else if (is_assoc .and. (cnt /= 11 .or. cnt2 /= 20)) then 138 stop 29 139 end if 140 end if 141 142 cnt = 30 143 cnt2 = 40 144 mycnt = 0 145 !$omp parallel shared(mycnt) 146 if (is_present .neqv. present (my_proc)) stop 30 147 !$omp critical 148 if (present (my_proc)) then 149 my_proc => proc2 150 if (.not.associated (my_proc, proc2)) stop 31 151 mycnt = mycnt + 1 152 call my_proc() 153 if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 32 154 end if 155 !$omp end critical 156 !$omp end parallel 157 if (present (my_proc)) then 158 if (.not.associated (my_proc, proc2)) stop 33 159 if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 34 160 end if 161 end 162 163 ! ---------------------- 164 165 subroutine cfun_check(my_cfun) 166 type(c_funptr) :: my_cfun 167 procedure(proc), pointer :: pptr 168 logical :: has_cfun 169 170 has_cfun = c_associated (my_cfun) 171 pptr => null() 172 cnt = 42 173 call c_f_procpointer (my_cfun, pptr) 174 if (has_cfun) then 175 call pptr() 176 if (cnt /= 43) stop 35 177 end if 178 179 pptr => null() 180 !$omp parallel 181 if (has_cfun .neqv. c_associated (my_cfun)) stop 36 182 !$omp critical 183 call c_f_procpointer (my_cfun, pptr) 184 !$omp end critical 185 if (has_cfun) then 186 call pptr() 187 if (cnt <= 43) stop 37 188 else 189 if (associated (pptr)) stop 38 190 end if 191 !$omp end parallel 192 end 193 194 subroutine cfun_check_opt(my_cfun) 195 type(c_funptr), optional :: my_cfun 196 procedure(proc), pointer :: pptr 197 logical :: has_cfun, is_present 198 199 has_cfun = .false. 200 is_present = present (my_cfun) 201 if (is_present) has_cfun = c_associated (my_cfun) 202 203 cnt = 1 204 pptr => null() 205 !$omp parallel 206 if (is_present .neqv. present (my_cfun)) stop 39 207 if (is_present) then 208 if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 40 209 !$omp critical 210 call c_f_procpointer (my_cfun, pptr) 211 !$omp end critical 212 if (has_cfun) then 213 call pptr() 214 if (cnt <= 1) stop 41 215 else 216 if (associated (pptr)) stop 42 217 end if 218 end if 219 !$omp end parallel 220 end 221 222 subroutine cfun_check_ptr(my_cfun) 223 type(c_funptr), pointer :: my_cfun 224 procedure(proc), pointer :: pptr 225 logical :: has_cfun, is_assoc 226 227 has_cfun = .false. 228 is_assoc = associated (my_cfun) 229 if (is_assoc) has_cfun = c_associated (my_cfun) 230 231 cnt = 1 232 pptr => null() 233 !$omp parallel 234 if (is_assoc .neqv. associated (my_cfun)) stop 43 235 if (is_assoc) then 236 if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 44 237 !$omp critical 238 call c_f_procpointer (my_cfun, pptr) 239 !$omp end critical 240 if (has_cfun) then 241 call pptr() 242 if (cnt <= 1) stop 45 243 else 244 if (associated (pptr)) stop 46 245 end if 246 end if 247 !$omp end parallel 248 249 cnt = 42 250 cnt2 = 1 251 pptr => null() 252 !$omp parallel 253 if (is_assoc .neqv. associated (my_cfun)) stop 47 254 if (is_assoc) then 255 !$omp critical 256 my_cfun = c_funloc (proc2) 257 call c_f_procpointer (my_cfun, pptr) 258 !$omp end critical 259 if (.not. associated (pptr, proc2)) stop 48 260 if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 49 261 call pptr() 262 if (cnt /= 42 .or. cnt2 <= 1) stop 50 263 end if 264 !$omp end parallel 265 if (is_assoc) then 266 if (.not. associated (pptr, proc2)) stop 51 267 if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 52 268 else 269 if (associated (pptr)) stop 53 270 end if 271 end 272 273 subroutine cfun_check_ptr_opt (my_cfun) 274 type(c_funptr), pointer, optional :: my_cfun 275 procedure(proc), pointer :: pptr 276 logical :: is_present, has_cfun, is_assoc 277 278 has_cfun = .false. 279 is_assoc = .false. 280 is_present = present (my_cfun) 281 if (is_present) then 282 is_assoc = associated (my_cfun) 283 if (is_assoc) has_cfun = c_associated (my_cfun) 284 end if 285 286 cnt = 1 287 pptr => null() 288 !$omp parallel 289 if (is_present .neqv. present (my_cfun)) stop 54 290 if (is_present) then 291 if (is_assoc .neqv. associated (my_cfun)) stop 55 292 if (is_assoc) then 293 if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 56 294 !$omp critical 295 call c_f_procpointer (my_cfun, pptr) 296 !$omp end critical 297 if (has_cfun) then 298 call pptr() 299 if (cnt <= 1) stop 57 300 else 301 if (associated (pptr)) stop 58 302 end if 303 end if 304 end if 305 !$omp end parallel 306 307 cnt = 42 308 cnt2 = 1 309 pptr => null() 310 !$omp parallel 311 if (is_present .neqv. present (my_cfun)) stop 59 312 if (is_present) then 313 if (is_assoc .neqv. associated (my_cfun)) stop 60 314 if (is_assoc) then 315 !$omp critical 316 my_cfun = c_funloc (proc2) 317 call c_f_procpointer (my_cfun, pptr) 318 !$omp end critical 319 if (.not. associated (pptr, proc2)) stop 61 320 if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 62 321 call pptr() 322 if (cnt /= 42 .or. cnt2 <= 1) stop 63 323 end if 324 end if 325 !$omp end parallel 326 if (is_present .and. is_assoc) then 327 if (.not. associated (pptr, proc2)) stop 64 328 if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 65 329 else 330 if (associated (pptr)) stop 66 331 end if 332 end 333end module m 334 335 336 337program main 338 use m 339 implicit none (type, external) 340 procedure(proc), pointer :: pptr 341 type(c_funptr), target :: cfun 342 type(c_funptr), pointer :: cfun_ptr 343 344 call check(proc) 345 call check_opt() 346 call check_opt(proc) 347 348 pptr => null() 349 call check_ptr(pptr) 350 pptr => proc 351 call check_ptr(pptr) 352 353 call check_ptr_opt() 354 pptr => null() 355 call check_ptr_opt(pptr) 356 pptr => proc 357 call check_ptr_opt(pptr) 358 359 ! ------------------- 360 pptr => null() 361 362 cfun = c_funloc (pptr) 363 call cfun_check(cfun) 364 365 cfun = c_funloc (proc) 366 call cfun_check(cfun) 367 368 call cfun_check_opt() 369 370 cfun = c_funloc (pptr) 371 call cfun_check_opt(cfun) 372 373 cfun = c_funloc (proc) 374 call cfun_check_opt(cfun) 375 376 ! - - - - 377 cfun_ptr => null() 378 call cfun_check_ptr (cfun_ptr) 379 380 cfun = c_funloc (proc) 381 cfun_ptr => cfun 382 call cfun_check_ptr (cfun_ptr) 383 384 ! - - - - 385 call cfun_check_ptr_opt () 386 387 cfun_ptr => null() 388 call cfun_check_ptr_opt (cfun_ptr) 389 390 cfun = c_funloc (proc) 391 cfun_ptr => cfun 392 call cfun_check_ptr_opt (cfun_ptr) 393end program 394