1! PR 101310 2! { dg-do run } 3! { dg-additional-sources "section-1-c.c dump-descriptors.c" } 4! { dg-additional-options "-g" } 5! 6! This program tests basic use of the CFI_section C library function on 7! a 1-dimensional pointer array. 8 9program testit 10 use iso_c_binding 11 implicit none 12 13 interface 14 subroutine ctest (p, lb, ub, s, r) bind (c) 15 use iso_c_binding 16 integer(C_INT), pointer :: p(:) 17 integer(C_INT), value :: lb, ub, s 18 integer(C_INT), pointer, intent(out) :: r(:) 19 end subroutine 20 21 end interface 22 23 integer(C_INT), target :: aa(32) 24 integer :: i 25 26 ! Initialize the test array by numbering its elements. 27 do i = 1, 32 28 aa(i) = i 29 end do 30 31 call test_p (aa, 0, 31, 15, 24, 3) ! zero lower bound 32 call test_p (aa, 1, 32, 16, 25, 3) ! non-zero lower bound 33 call test_p (aa, 4, 35, 16, 25, 3) ! some other lower bound 34 call test_p (aa, 1, 32, 32, 16, -2) ! negative step 35 stop 36 37contains 38 39 ! Test function for non-pointer array AA. 40 ! LO and HI are the bounds for the entire array. 41 ! LB, UB, and S describe the section to take, and use the 42 ! same indexing as LO and HI. 43 subroutine test_p (aa, lo, hi, lb, ub, s) 44 integer, target :: aa(1:hi-lo+1) 45 integer :: lo, hi, lb, ub, s 46 47 integer(C_INT), pointer :: pp(:), rr(:) 48 integer :: i, o 49 50 pp(lo:hi) => aa 51 if (lbound (pp, 1) .ne. lo) stop 121 52 if (ubound (pp, 1) .ne. hi) stop 122 53 nullify (rr) 54 call ctest (pp, lb, ub, s, rr) 55 56 ! Make sure the input pointer array has not been modified. 57 if (lbound (pp, 1) .ne. lo) stop 144 58 if (ubound (pp, 1) .ne. hi) stop 145 59 do i = lo, hi 60 if (pp(i) .ne. i - lo + 1) stop 146 61 end do 62 63 ! Make sure the output array has the expected bounds and elements. 64 if (.not. associated (rr)) stop 151 65 if (lbound (rr, 1) .ne. 1) stop 152 66 if (ubound (rr, 1) .ne. (ub - lb)/s + 1) stop 153 67 o = 1 68 do i = lb, ub, s 69 if (rr(o) .ne. i - lo + 1) stop 154 70 o = o + 1 71 end do 72 end subroutine 73 74end program 75 76