1! { dg-do run } 2! { dg-additional-sources c_loc_tests_2_funcs.c } 3module c_loc_tests_2 4use, intrinsic :: iso_c_binding 5implicit none 6 7interface 8 function test_scalar_address(cptr) bind(c) 9 use, intrinsic :: iso_c_binding, only: c_ptr, c_int 10 type(c_ptr), value :: cptr 11 integer(c_int) :: test_scalar_address 12 end function test_scalar_address 13 14 function test_array_address(cptr, num_elements) bind(c) 15 use, intrinsic :: iso_c_binding, only: c_ptr, c_int 16 type(c_ptr), value :: cptr 17 integer(c_int), value :: num_elements 18 integer(c_int) :: test_array_address 19 end function test_array_address 20 21 function test_type_address(cptr) bind(c) 22 use, intrinsic :: iso_c_binding, only: c_ptr, c_int 23 type(c_ptr), value :: cptr 24 integer(c_int) :: test_type_address 25 end function test_type_address 26end interface 27 28contains 29 subroutine test0() bind(c) 30 integer, target :: xtar 31 integer, pointer :: xptr 32 type(c_ptr) :: my_c_ptr_1 = c_null_ptr 33 type(c_ptr) :: my_c_ptr_2 = c_null_ptr 34 xtar = 100 35 xptr => xtar 36 my_c_ptr_1 = c_loc(xtar) 37 my_c_ptr_2 = c_loc(xptr) 38 if(test_scalar_address(my_c_ptr_1) .ne. 1) then 39 STOP 1 40 end if 41 if(test_scalar_address(my_c_ptr_2) .ne. 1) then 42 STOP 2 43 end if 44 end subroutine test0 45 46 subroutine test1() bind(c) 47 integer(c_int), target, dimension(100) :: int_array_tar 48 type(c_ptr) :: my_c_ptr_1 = c_null_ptr 49 type(c_ptr) :: my_c_ptr_2 = c_null_ptr 50 51 int_array_tar = 100_c_int 52 my_c_ptr_1 = c_loc(int_array_tar) 53 if(test_array_address(my_c_ptr_1, 100_c_int) .ne. 1) then 54 STOP 3 55 end if 56 end subroutine test1 57 58 subroutine test2() bind(c) 59 type, bind(c) :: f90type 60 integer(c_int) :: i 61 real(c_double) :: x 62 end type f90type 63 type(f90type), target :: type_tar 64 type(f90type), pointer :: type_ptr 65 type(c_ptr) :: my_c_ptr_1 = c_null_ptr 66 type(c_ptr) :: my_c_ptr_2 = c_null_ptr 67 68 type_ptr => type_tar 69 type_tar%i = 100 70 type_tar%x = 1.0d0 71 my_c_ptr_1 = c_loc(type_tar) 72 my_c_ptr_2 = c_loc(type_ptr) 73 if(test_type_address(my_c_ptr_1) .ne. 1) then 74 STOP 4 75 end if 76 if(test_type_address(my_c_ptr_2) .ne. 1) then 77 STOP 5 78 end if 79 end subroutine test2 80end module c_loc_tests_2 81 82program driver 83 use c_loc_tests_2 84 call test0() 85 call test1() 86 call test2() 87end program driver 88