gcc/testsuite/gfortran.dg/c-interop/fc-out-descriptor-7.f90

! PR 101310
! { dg-do run }
! { dg-additional-sources "fc-out-descriptor-7-c.c dump-descriptors.c" }
! { dg-additional-options "-g" }
!
! This program checks that returning a noncontiguous array as an intent(out)
! argument to a C function called from Fortran works.  

module mm
  use iso_c_binding
  type, bind (c) :: m
    integer(C_INT) :: i, j
  end type

  integer(C_INT), parameter :: imax = 10, jmax=5

end module

program testit
  use iso_c_binding
  use mm
  implicit none

  interface
    ! ctest points b at a section of array a defined by the
    ! indicated bounds and steps.  The returned array is 1-based.
    subroutine ctest (a, lb1, ub1, s1, lb2, ub2, s2, b) bind (c)
      use iso_c_binding
      use mm
      type(m), target :: a(:,:)
      integer(C_INT), value :: lb1, ub1, s1, lb2, ub2, s2
      type(m), intent(out), pointer :: b(:,:)
    end subroutine
  end interface

  type(m), target :: a(imax, jmax)
  type(m), pointer :: b(:,:)
  integer :: i, j, ii, jj

  do j = 1, jmax
    do i = 1, imax
      a(i,j)%i = i
      a(i,j)%j = j
    end do
  end do

  b => NULL ()
  ! resulting array is 1-based and has shape (3,3)
  call ctest (a, 2, 8, 3, 1, 5, 2, b)
  if (.not. associated (b)) stop 101
  if (rank(b) .ne. 2) stop 102
  if (lbound (b, 1) .ne. 1) stop 103
  if (ubound (b, 1) .ne. 3) stop 104
  if (lbound (b, 2) .ne. 1) stop 105
  if (ubound (b, 2) .ne. 3) stop 106

  ! check that the returned array b contains the expected elements
  ! from array a.
  jj = lbound (b, 2)
  do j = 1, 5, 2
    ii = lbound (b, 1)
    do i = 2, 8, 3
      if (b(ii,jj)%i .ne. i) stop 107
      if (b(ii,jj)%j .ne. j) stop 108
      ii = ii + 1
    end do
    jj = jj + 1
  end do

end program