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