1! PR 93308
2! { dg-do run }
3! { dg-additional-sources "cf-descriptor-2-c.c dump-descriptors.c" }
4!
5! This program checks that building a descriptor for a fixed-size array
6! in C works and that you can use it to call back into a Fortran function
7! declared to have c binding, as an assumed-rank argument.
8!
9! Fixed by
10! https://gcc.gnu.org/pipermail/gcc-patches/2021-June/572725.html
11
12module mm
13  use iso_c_binding
14  type, bind (c) :: m
15    integer(C_INT) :: i, j
16  end type
17
18  integer, parameter :: imax=10, jmax=5
19end module
20
21subroutine ftest (a, b) bind (c, name="ftest")
22  use iso_c_binding
23  use mm
24  type(m) :: a(..), b(..)
25  integer :: i, j
26
27  select rank (a)
28    rank (2)
29      select rank (b)
30        rank (2)
31	  ! print *, lbound(a,1), ubound(a,1), lbound(a,2), ubound(a,2)
32	  ! print *, lbound(b,1), ubound(b,1), lbound(b,2), ubound(b,2)
33          if (lbound (a,1) .ne. 1 .or. ubound (a,1) .ne. imax) stop 101
34          if (lbound (a,2) .ne. 1 .or. ubound (a,2) .ne. jmax) stop 102
35          if (lbound (b,1) .ne. 1 .or. ubound (b,1) .ne. jmax) stop 103
36          if (lbound (b,2) .ne. 1 .or. ubound (b,2) .ne. imax) stop 104
37	  do j = 1, jmax
38	    do i = 1, imax
39	      print *, a(i,j)%i, a(i,j)%j, b(j,i)%i, b(j,i)%j
40	      if (a(i,j)%i .ne. i) stop 105
41	      if (a(i,j)%j .ne. j) stop 106
42	      if (b(j,i)%i .ne. i) stop 107
43	      if (b(j,i)%j .ne. j) stop 108
44            end do
45	  end do
46        rank default
47          stop 106
48      end select
49    rank default
50      stop 107
51  end select
52end subroutine
53
54
55program testit
56  use iso_c_binding
57  use mm
58  implicit none
59
60  interface
61    subroutine ctest (a) bind (c)
62      use iso_c_binding
63      use mm
64      type(m) :: a(..)
65    end subroutine
66  end interface
67
68  type(m) :: aa(imax,jmax)
69  integer :: i, j
70  do j = 1, jmax
71    do i = 1, imax
72      aa(i,j)%i = i
73      aa(i,j)%j = j
74    end do
75  end do
76
77  ! Pass the initialized array to a C function ctest, which will generate its
78  ! transpose and call ftest with it.
79
80  call ctest (aa)
81
82end program
83