Fortran/OpenMP: Fix optional dummy procedures [PR99171]
gcc/fortran/ChangeLog: PR fortran/99171 * trans-openmp.c (gfc_omp_is_optional_argument): Regard optional dummy procs as nonoptional as no special treatment is needed. libgomp/ChangeLog: PR fortran/99171 * testsuite/libgomp.fortran/dummy-procs-1.f90: New test.
This commit is contained in:
Tobias Burnus
parent
451002e626
commit
e9b34037cd
@ -64,7 +64,9 @@ gfc_omp_is_allocatable_or_ptr (const_tree decl)
|
||||
/* True if the argument is an optional argument; except that false is also
|
||||
returned for arguments with the value attribute (nonpointers) and for
|
||||
assumed-shape variables (decl is a local variable containing arg->data).
|
||||
Note that pvoid_type_node is for 'type(c_ptr), value. */
|
||||
Note that for 'procedure(), optional' the value false is used as that's
|
||||
always a pointer and no additional indirection is used.
|
||||
Note that pvoid_type_node is for 'type(c_ptr), value' (and c_funloc). */
|
||||
|
||||
static bool
|
||||
gfc_omp_is_optional_argument (const_tree decl)
|
||||
@ -73,6 +75,7 @@ gfc_omp_is_optional_argument (const_tree decl)
|
||||
&& DECL_LANG_SPECIFIC (decl)
|
||||
&& TREE_CODE (TREE_TYPE (decl)) == POINTER_TYPE
|
||||
&& !VOID_TYPE_P (TREE_TYPE (TREE_TYPE (decl)))
|
||||
&& TREE_CODE (TREE_TYPE (TREE_TYPE (decl))) != FUNCTION_TYPE
|
||||
&& GFC_DECL_OPTIONAL_ARGUMENT (decl));
|
||||
}
|
||||
|
||||
|
||||
393
libgomp/testsuite/libgomp.fortran/dummy-procs-1.f90
Normal file
393
libgomp/testsuite/libgomp.fortran/dummy-procs-1.f90
Normal file
@ -0,0 +1,393 @@
|
||||
! { 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
|
||||
Loading…
Reference in New Issue
Block a user