gcc/testsuite/gfortran.dg/c_assoc.f90

   1 ! { dg-do run }
   2 ! { dg-additional-sources test_c_assoc.c }
   3 module c_assoc
   4   use, intrinsic :: iso_c_binding
   5   implicit none
   6
   7 contains
   8
   9   function test_c_assoc_0(my_c_ptr) bind(c)
  10     use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_associated
  11     integer(c_int) :: test_c_assoc_0
  12     type(c_ptr), value :: my_c_ptr
  13
  14     if(c_associated(my_c_ptr)) then
  15        test_c_assoc_0 = 1
  16     else
  17        test_c_assoc_0 = 0
  18     endif
  19   end function test_c_assoc_0
  20
  21   function test_c_assoc_1(my_c_ptr_1, my_c_ptr_2) bind(c)
  22     use, intrinsic :: iso_c_binding, only: c_ptr, c_int, c_associated
  23     integer(c_int) :: test_c_assoc_1
  24     type(c_ptr), value :: my_c_ptr_1
  25     type(c_ptr), value :: my_c_ptr_2
  26
  27     if(c_associated(my_c_ptr_1, my_c_ptr_2)) then
  28        test_c_assoc_1 = 1
  29     else
  30        test_c_assoc_1 = 0
  31     endif
  32   end function test_c_assoc_1
  33
  34   function test_c_assoc_2(my_c_ptr_1, my_c_ptr_2, num_ptrs) bind(c)
  35     integer(c_int) :: test_c_assoc_2
  36     type(c_ptr), value :: my_c_ptr_1
  37     type(c_ptr), value :: my_c_ptr_2
  38     integer(c_int), value :: num_ptrs
  39
  40     if(num_ptrs .eq. 1) then
  41        if(c_associated(my_c_ptr_1)) then
  42           test_c_assoc_2 = 1
  43        else
  44           test_c_assoc_2 = 0
  45        endif
  46     else
  47        if(c_associated(my_c_ptr_1, my_c_ptr_2)) then
  48           test_c_assoc_2 = 1
  49        else
  50           test_c_assoc_2 = 0
  51        endif
  52     endif
  53   end function test_c_assoc_2
  54
  55   subroutine verify_assoc(my_c_ptr_1, my_c_ptr_2) bind(c)
  56     type(c_ptr), value :: my_c_ptr_1
  57     type(c_ptr), value :: my_c_ptr_2
  58
  59     if(.not. c_associated(my_c_ptr_1)) then
  60        STOP 1
  61     else if(.not. c_associated(my_c_ptr_2)) then
  62        STOP 2
  63     else if(.not. c_associated(my_c_ptr_1, my_c_ptr_2)) then
  64        STOP 3
  65     endif
  66   end subroutine verify_assoc
  67
  68 end module c_assoc