| ! { 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 |