gcc/testsuite/gfortran.dg/c_loc_tests_2.f03

   1 ! { dg-do run }
   2 ! { dg-additional-sources c_loc_tests_2_funcs.c }
   3 module c_loc_tests_2
   4 use, intrinsic :: iso_c_binding
   5 implicit none
   6
   7 interface
   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
  26 end interface
  27
  28 contains
  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        call abort()
  40     end if
  41     if(test_scalar_address(my_c_ptr_2) .ne. 1) then
  42        call abort()
  43     end if
  44   end subroutine test0
  45
  46   subroutine test1() bind(c)
  47     integer, 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
  52     my_c_ptr_1 = c_loc(int_array_tar)
  53     if(test_array_address(my_c_ptr_1, 100) .ne. 1) then
  54        call abort()
  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        call abort()
  75     end if
  76     if(test_type_address(my_c_ptr_2) .ne. 1) then
  77        call abort()
  78     end if
  79   end subroutine test2
  80 end module c_loc_tests_2
  81
  82 program driver
  83   use c_loc_tests_2
  84   call test0()
  85   call test1()
  86   call test2()
  87 end program driver
  88 ! { dg-final { cleanup-modules "c_loc_tests_2" } }