gcc/testsuite/gfortran.dg/c_ptr_tests_17.f90

   1 ! { dg-do compile }
   2 !
   3 ! PR fortran/37829
   4 !
   5 ! Contributed by James Van Buskirk and Jerry DeLisle.
   6 !
   7 ! Fix derived-type loading with ISO_BIND_C's C_PTR/C_FUNPTR.
   8
   9 module m3
  10    use ISO_C_BINDING
  11    implicit none
  12    private
  13
  14    public kill_C_PTR
  15    interface
  16       function kill_C_PTR() bind(C)
  17          import
  18          implicit none
  19          type(C_PTR) kill_C_PTR
  20       end function kill_C_PTR
  21    end interface
  22
  23    public kill_C_FUNPTR
  24    interface
  25       function kill_C_FUNPTR() bind(C)
  26          import
  27          implicit none
  28          type(C_FUNPTR) kill_C_FUNPTR
  29       end function kill_C_FUNPTR
  30    end interface
  31 end module m3
  32
  33 module m1
  34    use m3
  35 end module m1
  36
  37 program X
  38    use m1
  39    use ISO_C_BINDING
  40    implicit none
  41    type(C_PTR) cp
  42    type(C_FUNPTR) fp
  43    integer(C_INT),target :: i
  44    interface
  45       function fun() bind(C)
  46          use ISO_C_BINDING
  47          implicit none
  48          real(C_FLOAT) fun
  49       end function fun
  50    end interface
  51
  52    cp = C_NULL_PTR
  53    cp = C_LOC(i)
  54    fp = C_NULL_FUNPTR
  55    fp = C_FUNLOC(fun)
  56 end program X
  57
  58 function fun() bind(C)
  59    use ISO_C_BINDING
  60    implicit none
  61    real(C_FLOAT) fun
  62    fun = 1.0
  63 end function fun
  64
  65 function kill_C_PTR() bind(C)
  66    use ISO_C_BINDING
  67    implicit none
  68    type(C_PTR) kill_C_PTR
  69    integer(C_INT), pointer :: p
  70    allocate(p)
  71    kill_C_PTR = C_LOC(p)
  72 end function kill_C_PTR
  73
  74 function kill_C_FUNPTR() bind(C)
  75    use ISO_C_BINDING
  76    implicit none
  77    type(C_FUNPTR) kill_C_FUNPTR
  78    interface
  79       function fun() bind(C)
  80          use ISO_C_BINDING
  81          implicit none
  82          real(C_FLOAT) fun
  83       end function fun
  84    end interface
  85    kill_C_FUNPTR = C_FUNLOC(fun)
  86 end function kill_C_FUNPTR