gcc/testsuite/gfortran.dg/c_assoc_5.f90

   1 ! { dg-do compile }
   2 !
   3 ! PR fortran/56969
   4 !
   5 ! Contributed by Salvatore Filippone
   6 !
   7 ! Was before rejected as the different c_associated weren't recognized to
   8 ! come from the same module.
   9 !
  10 module test_mod
  11   use iso_c_binding
  12
  13   type(c_ptr), save :: test_context = c_null_ptr
  14
  15   type, bind(c) :: s_Cmat
  16     type(c_ptr) :: Mat = c_null_ptr
  17   end type s_Cmat
  18
  19
  20   interface
  21     function FtestCreate(context) &
  22          & bind(c,name="FtestCreate") result(res)
  23       use iso_c_binding
  24       type(c_ptr)    :: context
  25       integer(c_int) :: res
  26     end function FtestCreate
  27   end interface
  28 contains
  29
  30   function initFtest() result(res)
  31     implicit none
  32     integer(c_int) :: res
  33     if (c_associated(test_context)) then
  34       res = 0
  35     else
  36       res = FtestCreate(test_context)
  37     end if
  38   end function initFtest
  39 end module test_mod
  40
  41 module base_mat_mod
  42   type base_sparse_mat
  43     integer, allocatable :: ia(:)
  44   end type base_sparse_mat
  45 end module base_mat_mod
  46
  47 module extd_mat_mod
  48
  49   use iso_c_binding
  50   use test_mod
  51   use base_mat_mod
  52
  53   type, extends(base_sparse_mat) :: extd_sparse_mat
  54     type(s_Cmat) :: deviceMat
  55   end type extd_sparse_mat
  56
  57 end module extd_mat_mod
  58
  59 subroutine extd_foo(a)
  60
  61   use extd_mat_mod
  62   implicit none
  63   class(extd_sparse_mat), intent(inout) :: a
  64
  65   if (c_associated(a%deviceMat%Mat)) then
  66     write(*,*) 'C Associated'
  67   end if
  68
  69 end subroutine extd_foo