blob: 4f42f166e8104d2f645396303ced3dd3d50faf84 [file] [log] [blame]
! { dg-do run }
! PR fortran/118080
!
! Test passing of scalar derived types (user-defined or ISO_C_BINDING)
! to dummy argument with OPTIONAL + VALUE attribute
!
! Original/initial testcase by Tobias Burnus
module m
use iso_c_binding
implicit none(type,external)
logical is_present
contains
subroutine f(x)
! void f (void * x, logical(kind=1) .x) - 2nd arg = is-present flag
type(c_ptr), optional, value :: x
if (present(x) .neqv. is_present) stop 1
if (present(x)) then
block
integer, pointer :: ptr
call c_f_pointer(x,ptr)
if (ptr /= 55) stop 2
end block
endif
end
end
module m0
use m
implicit none(type,external)
contains
subroutine test_pr118080
type(c_ptr) :: a
integer, target :: x
a = c_loc(x)
x = 55
is_present = .true.
call f(a)
is_present = .false.
call f()
! Trying again after the absent call:
is_present = .true.
call f(a)
print *, "Passed original test"
end subroutine test_pr118080
end
! Exercise ISO_C_BINDING uses
module m1
use iso_c_binding, only: c_ptr, c_funptr, C_NULL_PTR, C_NULL_FUNPTR
implicit none
logical :: is_present = .false.
integer :: base = 0
contains
subroutine test_c ()
type(c_ptr) :: x = C_NULL_PTR
type(c_funptr) :: y = C_NULL_FUNPTR
is_present = .true.
base = 10
! Tests with c_ptr:
call f_c (x)
call f_c_opt (x)
call f_c_val (x)
call f_c_opt_val (x)
call f_c2_opt (x)
call f_c2_opt_val (x)
! Tests with c_funptr:
call g_c (y)
call g_c_opt (y)
call g_c_val (y)
call g_c_opt_val (y)
call g_c2_opt (y)
call g_c2_opt_val (y)
! Elemental subroutine calls:
base = 20
call f_c ([x])
call f_c_opt ([x])
call f_c_val ([x])
call f_c_opt_val ([x])
call f_c2_opt ([x])
call f_c2_opt_val ([x])
call g_c ([y])
call g_c_opt ([y])
call g_c_val ([y])
call g_c_opt_val ([y])
call g_c2_opt ([y])
call g_c2_opt_val ([y])
is_present = .false.
base = 30
call f_c_opt ()
call f_c_opt_val ()
call f_c2_opt ()
call f_c2_opt_val ()
call g_c_opt ()
call g_c_opt_val ()
call g_c2_opt ()
call g_c2_opt_val ()
print *, "Passed test_c"
end subroutine test_c
elemental subroutine f_c (x)
type(c_ptr), intent(in) :: x
end
!
elemental subroutine f_c_val (x)
type(c_ptr), value :: x
call f_c (x)
end
!
elemental subroutine f_c_opt (x)
type(c_ptr), intent(in), optional :: x
if (present (x) .neqv. is_present) error stop base+1
end
!
elemental subroutine f_c_opt_val (x)
type(c_ptr), value, optional :: x
if (present (x) .neqv. is_present) error stop base+2
end
!
elemental subroutine f_c2_opt_val (x)
type(c_ptr), value, optional :: x
if (present (x) .neqv. is_present) error stop base+3
call f_c_opt (x)
call f_c_opt_val (x)
if (present (x)) call f_c (x)
if (present (x)) call f_c_val (x)
end
!
elemental subroutine f_c2_opt (x)
type(c_ptr), intent(in), optional :: x
if (present (x) .neqv. is_present) error stop base+4
call f_c_opt_val (x)
call f_c2_opt_val (x)
end
elemental subroutine g_c (x)
type(c_funptr), intent(in) :: x
end
!
elemental subroutine g_c_val (x)
type(c_funptr), value :: x
call g_c (x)
end
!
elemental subroutine g_c_opt (x)
type(c_funptr), intent(in), optional :: x
if (present (x) .neqv. is_present) error stop base+6
end
!
elemental subroutine g_c_opt_val (x)
type(c_funptr), value, optional :: x
if (present (x) .neqv. is_present) error stop base+7
end
!
elemental subroutine g_c2_opt_val (x)
type(c_funptr), value, optional :: x
if (present (x) .neqv. is_present) error stop base+8
call g_c_opt (x)
call g_c_opt_val (x)
if (present (x)) call g_c (x)
if (present (x)) call g_c_val (x)
end
!
elemental subroutine g_c2_opt (x)
type(c_funptr), intent(in), optional :: x
if (present (x) .neqv. is_present) error stop base+9
call g_c_opt_val (x)
call g_c2_opt_val (x)
end
!
end
! Exercise simple user-defined types
module m2
implicit none
type t1
character(42) :: c = ""
logical :: l = .false.
end type t1
type, bind(c) :: t2
real :: r(8) = 0.
complex :: c(4) = 0.
integer :: i = 0
end type t2
logical :: is_present = .false.
integer :: base = 0
contains
subroutine test_t ()
type(t1) :: x
type(t2) :: y
x% c = "foo"
is_present = .true.
base = 50
! Tests with t1:
call f_c (x)
call f_c_opt (x)
call f_c_val (x)
call f_c_opt_val (x)
call f_c2_opt (x)
call f_c2_opt_val (x)
! Tests with t2:
call g_c (y)
call g_c_opt (y)
call g_c_val (y)
call g_c_opt_val (y)
call g_c2_opt (y)
call g_c2_opt_val (y)
! Elemental subroutine calls:
base = 60
call f_c ([x])
call f_c_opt ([x])
call f_c_val ([x])
call f_c_opt_val ([x])
call f_c2_opt ([x])
call f_c2_opt_val ([x])
call g_c ([y])
call g_c_opt ([y])
call g_c_val ([y])
call g_c_opt_val ([y])
call g_c2_opt ([y])
call g_c2_opt_val ([y])
is_present = .false.
base = 70
call f_c_opt ()
call f_c_opt_val ()
call f_c2_opt ()
call f_c2_opt_val ()
call g_c_opt ()
call g_c_opt_val ()
call g_c2_opt ()
call g_c2_opt_val ()
print *, "Passed test_t"
end subroutine test_t
elemental subroutine f_c (x)
type(t1), intent(in) :: x
if (x% c /= "foo") error stop base
end
!
elemental subroutine f_c_val (x)
type(t1), value :: x
if (x% c /= "foo") error stop base+5
call f_c (x)
end
!
elemental subroutine f_c_opt (x)
type(t1), intent(in), optional :: x
if (present (x) .neqv. is_present) error stop base+1
end
!
elemental subroutine f_c_opt_val (x)
type(t1), value, optional :: x
if (present (x) .neqv. is_present) error stop base+2
end
!
elemental subroutine f_c2_opt_val (x)
type(t1), value, optional :: x
if (present (x) .neqv. is_present) error stop base+3
call f_c_opt (x)
call f_c_opt_val (x)
if (present (x)) call f_c (x)
if (present (x)) call f_c_val (x)
end
!
elemental subroutine f_c2_opt (x)
type(t1), intent(in), optional :: x
if (present (x) .neqv. is_present) error stop base+4
call f_c_opt_val (x)
call f_c2_opt_val (x)
end
elemental subroutine g_c (x)
type(t2), intent(in) :: x
end
!
elemental subroutine g_c_val (x)
type(t2), value :: x
call g_c (x)
end
!
elemental subroutine g_c_opt (x)
type(t2), intent(in), optional :: x
if (present (x) .neqv. is_present) error stop base+6
end
!
elemental subroutine g_c_opt_val (x)
type(t2), value, optional :: x
if (present (x) .neqv. is_present) error stop base+7
end
!
elemental subroutine g_c2_opt_val (x)
type(t2), value, optional :: x
if (present (x) .neqv. is_present) error stop base+8
call g_c_opt (x)
call g_c_opt_val (x)
if (present (x)) call g_c (x)
if (present (x)) call g_c_val (x)
end
!
elemental subroutine g_c2_opt (x)
type(t2), intent(in), optional :: x
if (present (x) .neqv. is_present) error stop base+9
call g_c_opt_val (x)
call g_c2_opt_val (x)
end
end
program pr118080
use m0
use m1
use m2
implicit none
call test_pr118080 ()
call test_c()
call test_t()
end