gcc/testsuite/gfortran.dg/PR100915.f90

! { dg-do run }
! { dg-additional-sources PR100915.c }
!
! Test the fix for PR100915
! 

module isof_m

  use, intrinsic :: iso_c_binding, only: &
    c_signed_char, c_int16_t
  
  implicit none

  private
  
  public :: &
    CFI_type_cptr, CFI_type_cfunptr
  
  public ::      &
    check_fn_as, &
    check_fn_ar
  
  public :: &
    mult2
  
  public ::          &
    cfi_encode_type
  
  integer, parameter :: CFI_type_t = c_int16_t
  
  integer(kind=c_int16_t), parameter :: CFI_type_mask = int(z"FF", kind=c_int16_t)
  integer(kind=c_int16_t), parameter :: CFI_type_kind_shift = 8_c_int16_t

  ! Intrinsic types. Their kind number defines their storage size. */
  integer(kind=c_signed_char), parameter :: CFI_type_cptr   = 7
  integer(kind=c_signed_char), parameter :: CFI_type_cfunptr   = 8

  interface
    subroutine check_fn_as(a, t, k, e, n) &
      bind(c, name="check_fn")
      use, intrinsic :: iso_c_binding, only: &
        c_int16_t, c_signed_char, c_size_t
      implicit none
      type(*),                       intent(in) :: a(:)
      integer(c_int16_t),     value, intent(in) :: t
      integer(c_signed_char), value, intent(in) :: k
      integer(c_size_t),      value, intent(in) :: e
      integer(c_size_t),      value, intent(in) :: n
    end subroutine check_fn_as
    subroutine check_fn_ar(a, t, k, e, n) &
      bind(c, name="check_fn")
      use, intrinsic :: iso_c_binding, only: &
        c_int16_t, c_signed_char, c_size_t
      implicit none
      type(*),                       intent(in) :: a(..)
      integer(c_int16_t),     value, intent(in) :: t
      integer(c_signed_char), value, intent(in) :: k
      integer(c_size_t),      value, intent(in) :: e
      integer(c_size_t),      value, intent(in) :: n
    end subroutine check_fn_ar
  end interface

contains

  function mult2(a) result(b) bind(c)
    use, intrinsic :: iso_c_binding, only: &
      c_int
  
    integer(kind=c_int), value, intent(in) :: a

    integer(kind=c_int) :: b

    b = 2_c_int * a
    return
  end function mult2
  
  elemental function cfi_encode_type(type, kind) result(itype)
    integer(kind=c_signed_char), intent(in) :: type
    integer(kind=c_signed_char), intent(in) :: kind

    integer(kind=c_int16_t) :: itype, ikind

    itype = int(type, kind=c_int16_t)
    itype = iand(itype, CFI_type_mask)
    ikind = int(kind, kind=c_int16_t)
    ikind = iand(ikind, CFI_type_mask)
    ikind = shiftl(ikind, CFI_type_kind_shift)
    itype = ior(ikind, itype)
    return
  end function cfi_encode_type
  
end module isof_m

module iso_check_m

  use, intrinsic :: iso_c_binding, only: &
    c_signed_char, c_int16_t, c_size_t

  use, intrinsic :: iso_c_binding, only: &
    c_funptr, c_funloc, c_associated

  use :: isof_m, only:  &
    CFI_type_cptr, CFI_type_cfunptr
  
  use :: isof_m, only: &
    check_fn_as,       &
    check_fn_ar
  
  use :: isof_m, only: &
    mult2
  
  use :: isof_m, only: &
    cfi_encode_type
  
  implicit none

  integer                           :: i
  integer(kind=c_size_t), parameter :: b = 8
  integer,                parameter :: n = 11
  
contains

  subroutine check_c_funptr()
    type(c_funptr) :: p(n)
    integer :: i
    !
    p = [(c_funloc(mult2), i=1,n)]
    call f_check_c_funptr_as(p)
    do i = 1, n
      if(.not.c_associated(p(i), c_funloc(mult2))) stop 1
    end do
    p = [(c_funloc(mult2), i=1,n)]
    call c_check_c_funptr_as(p)
    do i = 1, n
      if(.not.c_associated(p(i), c_funloc(mult2))) stop 2
    end do
    p = [(c_funloc(mult2), i=1,n)]
    call f_check_c_funptr_ar(p)
    do i = 1, n
      if(.not.c_associated(p(i), c_funloc(mult2))) stop 3
    end do
    p = [(c_funloc(mult2), i=1,n)]
    call c_check_c_funptr_ar(p)
    do i = 1, n
      if(.not.c_associated(p(i), c_funloc(mult2))) stop 4
    end do
    return
  end subroutine check_c_funptr

  subroutine f_check_c_funptr_as(a)
    type(c_funptr), intent(in) :: a(:)
    !
    integer(kind=c_int16_t)     :: t
    integer(kind=c_signed_char) :: k
    integer(kind=c_size_t)      :: e
    !
    k = 0
    e = storage_size(a)/b
    t = cfi_encode_type(CFI_type_cfunptr, k)
    ! Assumes 64-bit target.
    ! if(e/=8) stop 5
    do i = 1, n
      if(.not.c_associated(a(i), c_funloc(mult2))) stop 6
    end do
    call check_fn_as(a, t, k, e, 1_c_size_t)
    do i = 1, n
      if(.not.c_associated(a(i), c_funloc(mult2))) stop 7
    end do
    return
  end subroutine f_check_c_funptr_as

  subroutine c_check_c_funptr_as(a) bind(c)
    type(c_funptr), intent(in) :: a(:)
    integer(kind=c_int16_t)     :: t
    integer(kind=c_signed_char) :: k
    integer(kind=c_size_t)      :: e
    !
    k = 0
    e = storage_size(a)/b
    t = cfi_encode_type(CFI_type_cfunptr, k)
    ! Assumes 64-bit target.
    ! if(e/=8) stop 8
    do i = 1, n
      if(.not.c_associated(a(i), c_funloc(mult2))) stop 9
    end do
    call check_fn_as(a, t, k, e, 1_c_size_t)
    do i = 1, n
      if(.not.c_associated(a(i), c_funloc(mult2))) stop 10
    end do
    return
  end subroutine c_check_c_funptr_as

  subroutine f_check_c_funptr_ar(a)
    type(c_funptr), intent(in) :: a(..)
    !
    integer(kind=c_int16_t)     :: t
    integer(kind=c_signed_char) :: k
    integer(kind=c_size_t)      :: e
    !
    k = 0
    e = storage_size(a)/b
    t = cfi_encode_type(CFI_type_cfunptr, k)
    ! Assumes 64-bit target.
    ! if(e/=8) stop 11
    select rank(a)
    rank(1)
      do i = 1, n
        if(.not.c_associated(a(i), c_funloc(mult2))) stop 12
      end do
    rank default
      stop 13
    end select
    call check_fn_ar(a, t, k, e, 1_c_size_t)
    select rank(a)
    rank(1)
      do i = 1, n
        if(.not.c_associated(a(i), c_funloc(mult2))) stop 14
      end do
    rank default
      stop 15
    end select
    return
  end subroutine f_check_c_funptr_ar

  subroutine c_check_c_funptr_ar(a) bind(c)
    type(c_funptr), intent(in) :: a(..)
    integer(kind=c_int16_t)     :: t
    integer(kind=c_signed_char) :: k
    integer(kind=c_size_t)      :: e
    !
    k = 0
    e = storage_size(a)/b
    t = cfi_encode_type(CFI_type_cfunptr, k)
    ! Assumes 64-bit target.
    ! if(e/=8) stop 16
    select rank(a)
    rank(1)
      do i = 1, n
        if(.not.c_associated(a(i), c_funloc(mult2))) stop 17
      end do
    rank default
      stop 18
    end select
    call check_fn_ar(a, t, k, e, 1_c_size_t)
    select rank(a)
    rank(1)
      do i = 1, n
        if(.not.c_associated(a(i), c_funloc(mult2))) stop 19
      end do
    rank default
      stop 20
    end select
    return
  end subroutine c_check_c_funptr_ar

end module iso_check_m

program main_p
  
  use :: iso_check_m, only: &
    check_c_funptr

  implicit none

  call check_c_funptr()
  stop

end program main_p

!! Local Variables:
!! mode: f90
!! End: