! { dg-do run }
!
! PR fortran/99171
!
! Check dummy procedure arguments, especially optional ones
!
module m
use iso_c_binding
implicit none (type, external)
integer :: cnt
integer :: cnt2
contains
subroutine proc()
cnt = cnt + 1
end subroutine
subroutine proc2()
cnt2 = cnt2 + 1
end subroutine
subroutine check(my_proc)
procedure(proc) :: my_proc
cnt = 42
call my_proc()
if (cnt /= 43) stop 1
!$omp parallel
call my_proc()
!$omp end parallel
if (cnt <= 43) stop 2
end
subroutine check_opt(my_proc)
procedure(proc), optional :: my_proc
logical :: is_present
is_present = present(my_proc)
cnt = 55
if (present (my_proc)) then
call my_proc()
if (cnt /= 56) stop 3
endif
!$omp parallel
if (is_present .neqv. present (my_proc)) stop 4
if (present (my_proc)) then
call my_proc()
if (cnt <= 56) stop 5
end if
!$omp end parallel
if (is_present) then
if (cnt <= 56) stop 6
else if (cnt /= 55) then
stop 7
end if
end
subroutine check_ptr(my_proc)
procedure(proc), pointer :: my_proc
logical :: is_assoc
integer :: mycnt
is_assoc = associated (my_proc)
cnt = 10
cnt2 = 20
if (associated (my_proc)) then
call my_proc()
if (cnt /= 11 .or. cnt2 /= 20) stop 8
endif
!$omp parallel
if (is_assoc .neqv. associated (my_proc)) stop 9
if (associated (my_proc)) then
if (.not. associated (my_proc, proc)) stop 10
call my_proc()
if (cnt <= 11 .or. cnt2 /= 20) stop 11
else if (cnt /= 10 .or. cnt2 /= 20) then
stop 12
end if
!$omp end parallel
if (is_assoc .neqv. associated (my_proc)) stop 13
if (associated (my_proc)) then
if (cnt <= 11 .or. cnt2 /= 20) stop 14
else if (is_assoc .and. (cnt /= 11 .or. cnt2 /= 20)) then
stop 15
end if
cnt = 30
cnt2 = 40
mycnt = 0
!$omp parallel shared(mycnt)
!$omp critical
my_proc => proc2
if (.not.associated (my_proc, proc2)) stop 17
mycnt = mycnt + 1
call my_proc()
if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 18
!$omp end critical
!$omp end parallel
if (.not.associated (my_proc, proc2)) stop 19
if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 20
end
subroutine check_ptr_opt(my_proc)
procedure(proc), pointer, optional :: my_proc
logical :: is_assoc, is_present
integer :: mycnt
is_assoc = .false.
is_present = present(my_proc)
cnt = 10
cnt2 = 20
if (present (my_proc)) then
is_assoc = associated (my_proc)
if (associated (my_proc)) then
call my_proc()
if (cnt /= 11 .or. cnt2 /= 20) stop 21
endif
end if
!$omp parallel
if (is_present .neqv. present (my_proc)) stop 22
if (present (my_proc)) then
if (is_assoc .neqv. associated (my_proc)) stop 23
if (associated (my_proc)) then
if (.not. associated (my_proc, proc)) stop 24
call my_proc()
if (cnt <= 11 .or. cnt2 /= 20) stop 25
else if (cnt /= 10 .or. cnt2 /= 20) then
stop 26
end if
end if
!$omp end parallel
if (present (my_proc)) then
if (is_assoc .neqv. associated (my_proc)) stop 27
if (associated (my_proc)) then
if (cnt <= 11 .or. cnt2 /= 20) stop 28
else if (is_assoc .and. (cnt /= 11 .or. cnt2 /= 20)) then
stop 29
end if
end if
cnt = 30
cnt2 = 40
mycnt = 0
!$omp parallel shared(mycnt)
if (is_present .neqv. present (my_proc)) stop 30
!$omp critical
if (present (my_proc)) then
my_proc => proc2
if (.not.associated (my_proc, proc2)) stop 31
mycnt = mycnt + 1
call my_proc()
if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 32
end if
!$omp end critical
!$omp end parallel
if (present (my_proc)) then
if (.not.associated (my_proc, proc2)) stop 33
if (cnt2 /= 40 + mycnt .or. cnt /= 30) stop 34
end if
end
! ----------------------
subroutine cfun_check(my_cfun)
type(c_funptr) :: my_cfun
procedure(proc), pointer :: pptr
logical :: has_cfun
has_cfun = c_associated (my_cfun)
pptr => null()
cnt = 42
call c_f_procpointer (my_cfun, pptr)
if (has_cfun) then
call pptr()
if (cnt /= 43) stop 35
end if
pptr => null()
!$omp parallel
if (has_cfun .neqv. c_associated (my_cfun)) stop 36
!$omp critical
call c_f_procpointer (my_cfun, pptr)
!$omp end critical
if (has_cfun) then
call pptr()
if (cnt <= 43) stop 37
else
if (associated (pptr)) stop 38
end if
!$omp end parallel
end
subroutine cfun_check_opt(my_cfun)
type(c_funptr), optional :: my_cfun
procedure(proc), pointer :: pptr
logical :: has_cfun, is_present
has_cfun = .false.
is_present = present (my_cfun)
if (is_present) has_cfun = c_associated (my_cfun)
cnt = 1
pptr => null()
!$omp parallel
if (is_present .neqv. present (my_cfun)) stop 39
if (is_present) then
if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 40
!$omp critical
call c_f_procpointer (my_cfun, pptr)
!$omp end critical
if (has_cfun) then
call pptr()
if (cnt <= 1) stop 41
else
if (associated (pptr)) stop 42
end if
end if
!$omp end parallel
end
subroutine cfun_check_ptr(my_cfun)
type(c_funptr), pointer :: my_cfun
procedure(proc), pointer :: pptr
logical :: has_cfun, is_assoc
has_cfun = .false.
is_assoc = associated (my_cfun)
if (is_assoc) has_cfun = c_associated (my_cfun)
cnt = 1
pptr => null()
!$omp parallel
if (is_assoc .neqv. associated (my_cfun)) stop 43
if (is_assoc) then
if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 44
!$omp critical
call c_f_procpointer (my_cfun, pptr)
!$omp end critical
if (has_cfun) then
call pptr()
if (cnt <= 1) stop 45
else
if (associated (pptr)) stop 46
end if
end if
!$omp end parallel
cnt = 42
cnt2 = 1
pptr => null()
!$omp parallel
if (is_assoc .neqv. associated (my_cfun)) stop 47
if (is_assoc) then
!$omp critical
my_cfun = c_funloc (proc2)
call c_f_procpointer (my_cfun, pptr)
!$omp end critical
if (.not. associated (pptr, proc2)) stop 48
if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 49
call pptr()
if (cnt /= 42 .or. cnt2 <= 1) stop 50
end if
!$omp end parallel
if (is_assoc) then
if (.not. associated (pptr, proc2)) stop 51
if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 52
else
if (associated (pptr)) stop 53
end if
end
subroutine cfun_check_ptr_opt (my_cfun)
type(c_funptr), pointer, optional :: my_cfun
procedure(proc), pointer :: pptr
logical :: is_present, has_cfun, is_assoc
has_cfun = .false.
is_assoc = .false.
is_present = present (my_cfun)
if (is_present) then
is_assoc = associated (my_cfun)
if (is_assoc) has_cfun = c_associated (my_cfun)
end if
cnt = 1
pptr => null()
!$omp parallel
if (is_present .neqv. present (my_cfun)) stop 54
if (is_present) then
if (is_assoc .neqv. associated (my_cfun)) stop 55
if (is_assoc) then
if (has_cfun .neqv. c_associated (my_cfun, c_funloc(proc))) stop 56
!$omp critical
call c_f_procpointer (my_cfun, pptr)
!$omp end critical
if (has_cfun) then
call pptr()
if (cnt <= 1) stop 57
else
if (associated (pptr)) stop 58
end if
end if
end if
!$omp end parallel
cnt = 42
cnt2 = 1
pptr => null()
!$omp parallel
if (is_present .neqv. present (my_cfun)) stop 59
if (is_present) then
if (is_assoc .neqv. associated (my_cfun)) stop 60
if (is_assoc) then
!$omp critical
my_cfun = c_funloc (proc2)
call c_f_procpointer (my_cfun, pptr)
!$omp end critical
if (.not. associated (pptr, proc2)) stop 61
if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 62
call pptr()
if (cnt /= 42 .or. cnt2 <= 1) stop 63
end if
end if
!$omp end parallel
if (is_present .and. is_assoc) then
if (.not. associated (pptr, proc2)) stop 64
if (.not. c_associated (my_cfun, c_funloc(proc2))) stop 65
else
if (associated (pptr)) stop 66
end if
end
end module m
program main
use m
implicit none (type, external)
procedure(proc), pointer :: pptr
type(c_funptr), target :: cfun
type(c_funptr), pointer :: cfun_ptr
call check(proc)
call check_opt()
call check_opt(proc)
pptr => null()
call check_ptr(pptr)
pptr => proc
call check_ptr(pptr)
call check_ptr_opt()
pptr => null()
call check_ptr_opt(pptr)
pptr => proc
call check_ptr_opt(pptr)
! -------------------
pptr => null()
cfun = c_funloc (pptr)
call cfun_check(cfun)
cfun = c_funloc (proc)
call cfun_check(cfun)
call cfun_check_opt()
cfun = c_funloc (pptr)
call cfun_check_opt(cfun)
cfun = c_funloc (proc)
call cfun_check_opt(cfun)
! - - - -
cfun_ptr => null()
call cfun_check_ptr (cfun_ptr)
cfun = c_funloc (proc)
cfun_ptr => cfun
call cfun_check_ptr (cfun_ptr)
! - - - -
call cfun_check_ptr_opt ()
cfun_ptr => null()
call cfun_check_ptr_opt (cfun_ptr)
cfun = c_funloc (proc)
cfun_ptr => cfun
call cfun_check_ptr_opt (cfun_ptr)
end program