394 lines
9.7 KiB
Fortran
394 lines
9.7 KiB
Fortran
|
! { 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
|