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