1! PR 101310 2! { dg-do run } 3! { dg-additional-sources "section-3-c.c dump-descriptors.c" } 4! { dg-additional-options "-g" } 5! 6! This program tests basic use of the CFI_section C library function to 7! take a slice of a 2-dimensional pointer array. 8 9module mm 10 use ISO_C_BINDING 11 type, bind (c) :: m 12 integer(C_INT) :: x, y 13 end type 14end module 15 16program testit 17 use iso_c_binding 18 use mm 19 implicit none 20 21 interface 22 subroutine ctest (p, lb0, lb1, ub0, ub1, s0, s1, r) bind (c) 23 use iso_c_binding 24 use mm 25 type(m), pointer :: p(:,:) 26 integer(C_INT), value :: lb0, lb1, ub0, ub1, s0, s1 27 type(m), pointer, intent(out) :: r(:) 28 end subroutine 29 30 end interface 31 32 type(m), target :: aa(10, 20) 33 integer :: i0, i1 34 35 ! Initialize the test array by numbering its elements. 36 do i1 = 1, 20 37 do i0 = 1, 10 38 aa(i0, i1)%x = i0 39 aa(i0, i1)%y = i1 40 end do 41 end do 42 43 ! Zero lower bound 44 call test (aa, 0, 0, 2, 0, 2, 19, 0, 1) ! full slice 0 45 call test (aa, 0, 0, 0, 7, 9, 7, 1, 0) ! full slice 1 46 call test (aa, 0, 0, 2, 4, 2, 13, 0, 3) ! partial slice 0 47 call test (aa, 0, 0, 1, 7, 9, 7, 2, 0) ! partial slice 1 48 call test (aa, 0, 0, 2, 13, 2, 4, 0, -3) ! backwards slice 0 49 call test (aa, 0, 0, 9, 7, 1, 7, -2, 0) ! backwards slice 1 50 51 ! Lower bound 1 52 call test (aa, 1, 1, 3, 1, 3, 20, 0, 1) ! full slice 0 53 call test (aa, 1, 1, 1, 8, 10, 8, 1, 0) ! full slice 1 54 call test (aa, 1, 1, 3, 5, 3, 14, 0, 3) ! partial slice 0 55 call test (aa, 1, 1, 2, 8, 10, 8, 2, 0) ! partial slice 1 56 call test (aa, 1, 1, 3, 14, 3, 5, 0, -3) ! backwards slice 0 57 call test (aa, 1, 1, 10, 8, 2, 8, -2, 0) ! backwards slice 1 58 59 ! Some other lower bound 60 call test (aa, 2, 3, 4, 3, 4, 22, 0, 1) ! full slice 0 61 call test (aa, 2, 3, 2, 10, 11, 10, 1, 0) ! full slice 1 62 call test (aa, 2, 3, 4, 7, 4, 16, 0, 3) ! partial slice 0 63 call test (aa, 2, 3, 3, 10, 11, 10, 2, 0) ! partial slice 1 64 call test (aa, 2, 3, 4, 16, 4, 7, 0, -3) ! backwards slice 0 65 call test (aa, 2, 3, 11, 10, 3, 10, -2, 0) ! backwards slice 1 66 67contains 68 69 subroutine test (aa, lo0, lo1, lb0, lb1, ub0, ub1, s0, s1) 70 use mm 71 type(m), target :: aa(10,20) 72 integer :: lo0, lo1, lb0, lb1, ub0, ub1, s0, s1 73 74 type(m), pointer :: pp(:,:), rr(:) 75 integer :: i0, i1, o0, o1 76 77 integer :: hi0, hi1 78 hi0 = lo0 + 10 - 1 79 hi1 = lo1 + 20 - 1 80 81 ! Check the bounds actually specify a "slice" rather than a subarray. 82 if (lb0 .ne. ub0 .and. lb1 .ne. ub1) stop 100 83 84 pp(lo0:,lo1:) => aa 85 if (lbound (pp, 1) .ne. lo0) stop 121 86 if (lbound (pp, 2) .ne. lo1) stop 121 87 if (ubound (pp, 1) .ne. hi0) stop 122 88 if (ubound (pp, 2) .ne. hi1) stop 122 89 nullify (rr) 90 call ctest (pp, lb0, lb1, ub0, ub1, s0, s1, rr) 91 92 ! Make sure the input pointer array has not been modified. 93 if (lbound (pp, 1) .ne. lo0) stop 131 94 if (ubound (pp, 1) .ne. hi0) stop 132 95 if (lbound (pp, 2) .ne. lo1) stop 133 96 if (ubound (pp, 2) .ne. hi1) stop 134 97 do i1 = lo1, hi1 98 do i0 = lo0, hi0 99 if (pp(i0,i1)%x .ne. i0 - lo0 + 1) stop 135 100 if (pp(i0,i1)%y .ne. i1 - lo1 + 1) stop 136 101 end do 102 end do 103 104 ! Make sure the output array has the expected bounds and elements. 105 if (.not. associated (rr)) stop 111 106 if (lbound (rr, 1) .ne. 1) stop 112 107 if (ub0 .eq. lb0) then 108 if (ubound (rr, 1) .ne. (ub1 - lb1)/s1 + 1) stop 113 109 o1 = 1 110 do i1 = lb1, ub1, s1 111 if (rr(o1)%x .ne. lb0 - lo0 + 1) stop 114 112 if (rr(o1)%y .ne. i1 - lo1 + 1) stop 114 113 o1 = o1 + 1 114 end do 115 else 116 if (ubound (rr, 1) .ne. (ub0 - lb0)/s0 + 1) stop 113 117 o0 = 1 118 do i0 = lb0, ub0, s0 119 if (rr(o0)%x .ne. i0 - lo0 + 1) stop 114 120 if (rr(o0)%y .ne. lb1 - lo1 + 1) stop 114 121 o0 = o0 + 1 122 end do 123 end if 124 end subroutine 125 126end program 127 128