gcc/testsuite/gfortran.dg/PR100915.f90

   1 ! { dg-do run }
   2 ! { dg-additional-sources PR100915.c }
   3 !
   4 ! Test the fix for PR100915
   5 !
   6
   7 module isof_m
   8
   9   use, intrinsic :: iso_c_binding, only: &
  10     c_signed_char, c_int16_t
  11
  12   implicit none
  13
  14   private
  15
  16   public :: &
  17     CFI_type_cptr, CFI_type_cfunptr
  18
  19   public ::      &
  20     check_fn_as, &
  21     check_fn_ar
  22
  23   public :: &
  24     mult2
  25
  26   public ::          &
  27     cfi_encode_type
  28
  29   integer, parameter :: CFI_type_t = c_int16_t
  30
  31   integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t)
  32   integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t
  33
  34   ! Intrinsic types. Their kind number defines their storage size. */
  35   integer(kind=c_signed_char), parameter :: CFI_type_cptr   = 7
  36   integer(kind=c_signed_char), parameter :: CFI_type_cfunptr   = 8
  37
  38   interface
  39     subroutine check_fn_as(a, t, k, e, n) &
  40       bind(c, name="check_fn")
  41       use, intrinsic :: iso_c_binding, only: &
  42         c_int16_t, c_signed_char, c_size_t
  43       implicit none
  44       type(*),                       intent(in) :: a(:)
  45       integer(c_int16_t),     value, intent(in) :: t
  46       integer(c_signed_char), value, intent(in) :: k
  47       integer(c_size_t),      value, intent(in) :: e
  48       integer(c_size_t),      value, intent(in) :: n
  49     end subroutine check_fn_as
  50     subroutine check_fn_ar(a, t, k, e, n) &
  51       bind(c, name="check_fn")
  52       use, intrinsic :: iso_c_binding, only: &
  53         c_int16_t, c_signed_char, c_size_t
  54       implicit none
  55       type(*),                       intent(in) :: a(..)
  56       integer(c_int16_t),     value, intent(in) :: t
  57       integer(c_signed_char), value, intent(in) :: k
  58       integer(c_size_t),      value, intent(in) :: e
  59       integer(c_size_t),      value, intent(in) :: n
  60     end subroutine check_fn_ar
  61   end interface
  62
  63 contains
  64
  65   function mult2(a) result(b) bind(c)
  66     use, intrinsic :: iso_c_binding, only: &
  67       c_int
  68
  69     integer(kind=c_int), value, intent(in) :: a
  70
  71     integer(kind=c_int) :: b
  72
  73     b = 2_c_int * a
  74     return
  75   end function mult2
  76
  77   elemental function cfi_encode_type(type, kind) result(itype)
  78     integer(kind=c_signed_char), intent(in) :: type
  79     integer(kind=c_signed_char), intent(in) :: kind
  80
  81     integer(kind=c_int16_t) :: itype, ikind
  82
  83     itype = int(type, kind=c_int16_t)
  84     itype = iand(itype, CFI_type_mask)
  85     ikind = int(kind, kind=c_int16_t)
  86     ikind = iand(ikind, CFI_type_mask)
  87     ikind = shiftl(ikind, CFI_type_kind_shift)
  88     itype = ior(ikind, itype)
  89     return
  90   end function cfi_encode_type
  91
  92 end module isof_m
  93
  94 module iso_check_m
  95
  96   use, intrinsic :: iso_c_binding, only: &
  97     c_signed_char, c_int16_t, c_size_t
  98
  99   use, intrinsic :: iso_c_binding, only: &
 100     c_funptr, c_funloc, c_associated
 101
 102   use :: isof_m, only:  &
 103     CFI_type_cptr, CFI_type_cfunptr
 104
 105   use :: isof_m, only: &
 106     check_fn_as,       &
 107     check_fn_ar
 108
 109   use :: isof_m, only: &
 110     mult2
 111
 112   use :: isof_m, only: &
 113     cfi_encode_type
 114
 115   implicit none
 116
 117   integer                           :: i
 118   integer(kind=c_size_t), parameter :: b = 8
 119   integer,                parameter :: n = 11
 120
 121 contains
 122
 123   subroutine check_c_funptr()
 124     type(c_funptr) :: p(n)
 125     integer :: i
 126     !
 127     p = [(c_funloc(mult2), i=1,n)]
 128     call f_check_c_funptr_as(p)
 129     do i = 1, n
 130       if(.not.c_associated(p(i), c_funloc(mult2))) stop 1
 131     end do
 132     p = [(c_funloc(mult2), i=1,n)]
 133     call c_check_c_funptr_as(p)
 134     do i = 1, n
 135       if(.not.c_associated(p(i), c_funloc(mult2))) stop 2
 136     end do
 137     p = [(c_funloc(mult2), i=1,n)]
 138     call f_check_c_funptr_ar(p)
 139     do i = 1, n
 140       if(.not.c_associated(p(i), c_funloc(mult2))) stop 3
 141     end do
 142     p = [(c_funloc(mult2), i=1,n)]
 143     call c_check_c_funptr_ar(p)
 144     do i = 1, n
 145       if(.not.c_associated(p(i), c_funloc(mult2))) stop 4
 146     end do
 147     return
 148   end subroutine check_c_funptr
 149
 150   subroutine f_check_c_funptr_as(a)
 151     type(c_funptr), intent(in) :: a(:)
 152     !
 153     integer(kind=c_int16_t)     :: t
 154     integer(kind=c_signed_char) :: k
 155     integer(kind=c_size_t)      :: e
 156     !
 157     k = 0
 158     e = storage_size(a)/b
 159     t = cfi_encode_type(CFI_type_cfunptr, k)
 160     ! Assumes 64-bit target.
 161     ! if(e/=8) stop 5
 162     do i = 1, n
 163       if(.not.c_associated(a(i), c_funloc(mult2))) stop 6
 164     end do
 165     call check_fn_as(a, t, k, e, 1_c_size_t)
 166     do i = 1, n
 167       if(.not.c_associated(a(i), c_funloc(mult2))) stop 7
 168     end do
 169     return
 170   end subroutine f_check_c_funptr_as
 171
 172   subroutine c_check_c_funptr_as(a) bind(c)
 173     type(c_funptr), intent(in) :: a(:)
 174     integer(kind=c_int16_t)     :: t
 175     integer(kind=c_signed_char) :: k
 176     integer(kind=c_size_t)      :: e
 177     !
 178     k = 0
 179     e = storage_size(a)/b
 180     t = cfi_encode_type(CFI_type_cfunptr, k)
 181     ! Assumes 64-bit target.
 182     ! if(e/=8) stop 8
 183     do i = 1, n
 184       if(.not.c_associated(a(i), c_funloc(mult2))) stop 9
 185     end do
 186     call check_fn_as(a, t, k, e, 1_c_size_t)
 187     do i = 1, n
 188       if(.not.c_associated(a(i), c_funloc(mult2))) stop 10
 189     end do
 190     return
 191   end subroutine c_check_c_funptr_as
 192
 193   subroutine f_check_c_funptr_ar(a)
 194     type(c_funptr), intent(in) :: a(..)
 195     !
 196     integer(kind=c_int16_t)     :: t
 197     integer(kind=c_signed_char) :: k
 198     integer(kind=c_size_t)      :: e
 199     !
 200     k = 0
 201     e = storage_size(a)/b
 202     t = cfi_encode_type(CFI_type_cfunptr, k)
 203     ! Assumes 64-bit target.
 204     ! if(e/=8) stop 11
 205     select rank(a)
 206     rank(1)
 207       do i = 1, n
 208         if(.not.c_associated(a(i), c_funloc(mult2))) stop 12
 209       end do
 210     rank default
 211       stop 13
 212     end select
 213     call check_fn_ar(a, t, k, e, 1_c_size_t)
 214     select rank(a)
 215     rank(1)
 216       do i = 1, n
 217         if(.not.c_associated(a(i), c_funloc(mult2))) stop 14
 218       end do
 219     rank default
 220       stop 15
 221     end select
 222     return
 223   end subroutine f_check_c_funptr_ar
 224
 225   subroutine c_check_c_funptr_ar(a) bind(c)
 226     type(c_funptr), intent(in) :: a(..)
 227     integer(kind=c_int16_t)     :: t
 228     integer(kind=c_signed_char) :: k
 229     integer(kind=c_size_t)      :: e
 230     !
 231     k = 0
 232     e = storage_size(a)/b
 233     t = cfi_encode_type(CFI_type_cfunptr, k)
 234     ! Assumes 64-bit target.
 235     ! if(e/=8) stop 16
 236     select rank(a)
 237     rank(1)
 238       do i = 1, n
 239         if(.not.c_associated(a(i), c_funloc(mult2))) stop 17
 240       end do
 241     rank default
 242       stop 18
 243     end select
 244     call check_fn_ar(a, t, k, e, 1_c_size_t)
 245     select rank(a)
 246     rank(1)
 247       do i = 1, n
 248         if(.not.c_associated(a(i), c_funloc(mult2))) stop 19
 249       end do
 250     rank default
 251       stop 20
 252     end select
 253     return
 254   end subroutine c_check_c_funptr_ar
 255
 256 end module iso_check_m
 257
 258 program main_p
 259
 260   use :: iso_check_m, only: &
 261     check_c_funptr
 262
 263   implicit none
 264
 265   call check_c_funptr()
 266   stop
 267
 268 end program main_p
 269
 270 !! Local Variables:
 271 !! mode: f90
 272 !! End:
 273