| ! { dg-do run } |
| ! |
| ! PR fortran/48820 |
| ! |
| ! Test TYPE(*) |
| ! |
| |
| module mod |
| use iso_c_binding, only: c_loc, c_ptr, c_bool |
| implicit none |
| interface my_c_loc |
| function my_c_loc1(x) bind(C) |
| import c_ptr |
| type(*) :: x |
| type(c_ptr) :: my_c_loc1 |
| end function |
| function my_c_loc2(x) bind(C) |
| import c_ptr |
| type(*) :: x(*) |
| type(c_ptr) :: my_c_loc2 |
| end function |
| end interface my_c_loc |
| contains |
| subroutine sub_scalar (arg1, presnt) |
| type(*), target, optional :: arg1 |
| logical :: presnt |
| type(c_ptr) :: cpt |
| if (presnt .neqv. present (arg1)) STOP 1 |
| cpt = c_loc (arg1) |
| end subroutine sub_scalar |
| |
| subroutine sub_array_shape (arg2, lbounds, ubounds) |
| type(*), target :: arg2(:,:) |
| type(c_ptr) :: cpt |
| integer :: lbounds(2), ubounds(2) |
| if (any (lbound(arg2) /= lbounds)) STOP 2 |
| if (any (ubound(arg2) /= ubounds)) STOP 3 |
| if (any (shape(arg2) /= ubounds-lbounds+1)) STOP 4 |
| if (size(arg2) /= product (ubounds-lbounds+1)) STOP 5 |
| if (rank (arg2) /= 2) STOP 6 |
| ! if (.not. is_continuous (arg2)) STOP 7 !<< Not yet implemented |
| ! cpt = c_loc (arg2) ! << FIXME: Valid since TS29113 |
| call sub_array_assumed (arg2) |
| end subroutine sub_array_shape |
| |
| subroutine sub_array_assumed (arg3) |
| type(*), target :: arg3(*) |
| type(c_ptr) :: cpt |
| cpt = c_loc (arg3) |
| end subroutine sub_array_assumed |
| end module |
| |
| use mod |
| use iso_c_binding, only: c_int, c_null_ptr |
| implicit none |
| type t1 |
| integer :: a |
| end type t1 |
| type :: t2 |
| sequence |
| integer :: b |
| end type t2 |
| type, bind(C) :: t3 |
| integer(c_int) :: c |
| end type t3 |
| |
| integer :: scalar_int |
| real, allocatable :: scalar_real_alloc |
| character, pointer :: scalar_char_ptr |
| |
| integer :: array_int(3) |
| real, allocatable :: array_real_alloc(:,:) |
| character, pointer :: array_char_ptr(:,:) |
| |
| type(t1) :: scalar_t1 |
| type(t2), allocatable :: scalar_t2_alloc |
| type(t3), pointer :: scalar_t3_ptr |
| |
| type(t1) :: array_t1(4) |
| type(t2), allocatable :: array_t2_alloc(:,:) |
| type(t3), pointer :: array_t3_ptr(:,:) |
| |
| class(t1), allocatable :: scalar_class_t1_alloc |
| class(t1), pointer :: scalar_class_t1_ptr |
| |
| class(t1), allocatable :: array_class_t1_alloc(:,:) |
| class(t1), pointer :: array_class_t1_ptr(:,:) |
| |
| scalar_char_ptr => null() |
| scalar_t3_ptr => null() |
| |
| call sub_scalar (presnt=.false.) |
| call sub_scalar (scalar_real_alloc, .false.) |
| call sub_scalar (scalar_char_ptr, .false.) |
| call sub_scalar (null (), .false.) |
| call sub_scalar (scalar_t2_alloc, .false.) |
| call sub_scalar (scalar_t3_ptr, .false.) |
| |
| allocate (scalar_real_alloc, scalar_char_ptr, scalar_t3_ptr) |
| allocate (scalar_class_t1_alloc, scalar_class_t1_ptr, scalar_t2_alloc) |
| allocate (array_real_alloc(3:5,2:4), array_char_ptr(-2:2,2)) |
| allocate (array_t2_alloc(3:5,2:4), array_t3_ptr(-2:2,2)) |
| allocate (array_class_t1_alloc(3,3), array_class_t1_ptr(4,4)) |
| |
| call sub_scalar (scalar_int, .true.) |
| call sub_scalar (scalar_real_alloc, .true.) |
| call sub_scalar (scalar_char_ptr, .true.) |
| call sub_scalar (array_int(2), .true.) |
| call sub_scalar (array_real_alloc(3,2), .true.) |
| call sub_scalar (array_char_ptr(0,1), .true.) |
| call sub_scalar (scalar_t1, .true.) |
| call sub_scalar (scalar_t2_alloc, .true.) |
| call sub_scalar (scalar_t3_ptr, .true.) |
| call sub_scalar (array_t1(2), .true.) |
| call sub_scalar (array_t2_alloc(3,2), .true.) |
| call sub_scalar (array_t3_ptr(0,1), .true.) |
| call sub_scalar (array_class_t1_alloc(2,1), .true.) |
| call sub_scalar (array_class_t1_ptr(3,3), .true.) |
| |
| call sub_array_assumed (array_int) |
| call sub_array_assumed (array_real_alloc) |
| call sub_array_assumed (array_char_ptr) |
| call sub_array_assumed (array_t1) |
| call sub_array_assumed (array_t2_alloc) |
| call sub_array_assumed (array_t3_ptr) |
| call sub_array_assumed (array_class_t1_alloc) |
| call sub_array_assumed (array_class_t1_ptr) |
| |
| call sub_array_shape (array_real_alloc, [1,1], shape(array_real_alloc)) |
| call sub_array_shape (array_char_ptr, [1,1], shape(array_char_ptr)) |
| call sub_array_shape (array_t2_alloc, [1,1], shape(array_t2_alloc)) |
| call sub_array_shape (array_t3_ptr, [1,1], shape(array_t3_ptr)) |
| call sub_array_shape (array_class_t1_alloc, [1,1], shape(array_class_t1_alloc)) |
| call sub_array_shape (array_class_t1_ptr, [1,1], shape(array_class_t1_ptr)) |
| |
| deallocate (scalar_char_ptr, scalar_class_t1_ptr, array_char_ptr) |
| deallocate (array_class_t1_ptr, array_t3_ptr) |
| |
| end |
