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