1 ! Copyright 2019-2024 Free Software Foundation, Inc.
3 ! This program is free software; you can redistribute it and/or modify
4 ! it under the terms of the GNU General Public License as published by
5 ! the Free Software Foundation; either version 3 of the License, or
6 ! (at your option) any later version.
8 ! This program is distributed in the hope that it will be useful,
9 ! but WITHOUT ANY WARRANTY; without even the implied warranty of
10 ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 ! GNU General Public License for more details.
13 ! You should have received a copy of the GNU General Public License
14 ! along with this program. If not, see <http://www.gnu.org/licenses/>.
16 subroutine show_elem (array)
20 print *, "Expected GDB Output:"
23 write(*, fmt="(A)", advance="no") "GDB = "
24 write(*, fmt="(I0)", advance="no") array
25 write(*, fmt="(A)", advance="yes") ""
27 print *, "" ! Display Element
28 end subroutine show_elem
30 subroutine show_str (array)
31 character (len=*) :: array
34 print *, "Expected GDB Output:"
36 write (*, fmt="(A)", advance="no") "GDB = '"
37 write (*, fmt="(A)", advance="no") array
38 write (*, fmt="(A)", advance="yes") "'"
40 print *, "" ! Display String
41 end subroutine show_str
43 subroutine show_1d (array)
44 integer, dimension (:) :: array
46 print *, "Array Contents:"
49 do i=LBOUND (array, 1), UBOUND (array, 1), 1
50 write(*, fmt="(i4)", advance="no") array (i)
54 print *, "Expected GDB Output:"
57 write(*, fmt="(A)", advance="no") "GDB = ("
58 do i=LBOUND (array, 1), UBOUND (array, 1), 1
59 if (i > LBOUND (array, 1)) then
60 write(*, fmt="(A)", advance="no") ", "
62 write(*, fmt="(I0)", advance="no") array (i)
64 write(*, fmt="(A)", advance="yes") ")"
66 print *, "" ! Display Array Slice 1D
67 end subroutine show_1d
69 subroutine show_2d (array)
70 integer, dimension (:,:) :: array
72 print *, "Array Contents:"
75 do i=LBOUND (array, 2), UBOUND (array, 2), 1
76 do j=LBOUND (array, 1), UBOUND (array, 1), 1
77 write(*, fmt="(i4)", advance="no") array (j, i)
83 print *, "Expected GDB Output:"
86 write(*, fmt="(A)", advance="no") "GDB = ("
87 do i=LBOUND (array, 2), UBOUND (array, 2), 1
88 if (i > LBOUND (array, 2)) then
89 write(*, fmt="(A)", advance="no") " "
91 write(*, fmt="(A)", advance="no") "("
92 do j=LBOUND (array, 1), UBOUND (array, 1), 1
93 if (j > LBOUND (array, 1)) then
94 write(*, fmt="(A)", advance="no") ", "
96 write(*, fmt="(I0)", advance="no") array (j, i)
98 write(*, fmt="(A)", advance="no") ")"
100 write(*, fmt="(A)", advance="yes") ")"
102 print *, "" ! Display Array Slice 2D
103 end subroutine show_2d
105 subroutine show_3d (array)
106 integer, dimension (:,:,:) :: array
109 print *, "Expected GDB Output:"
112 write(*, fmt="(A)", advance="no") "GDB = ("
113 do i=LBOUND (array, 3), UBOUND (array, 3), 1
114 if (i > LBOUND (array, 3)) then
115 write(*, fmt="(A)", advance="no") " "
117 write(*, fmt="(A)", advance="no") "("
118 do j=LBOUND (array, 2), UBOUND (array, 2), 1
119 if (j > LBOUND (array, 2)) then
120 write(*, fmt="(A)", advance="no") " "
122 write(*, fmt="(A)", advance="no") "("
123 do k=LBOUND (array, 1), UBOUND (array, 1), 1
124 if (k > LBOUND (array, 1)) then
125 write(*, fmt="(A)", advance="no") ", "
127 write(*, fmt="(I0)", advance="no") array (k, j, i)
129 write(*, fmt="(A)", advance="no") ")"
131 write(*, fmt="(A)", advance="no") ")"
133 write(*, fmt="(A)", advance="yes") ")"
135 print *, "" ! Display Array Slice 3D
136 end subroutine show_3d
138 subroutine show_4d (array)
139 integer, dimension (:,:,:,:) :: array
142 print *, "Expected GDB Output:"
145 write(*, fmt="(A)", advance="no") "GDB = ("
146 do i=LBOUND (array, 4), UBOUND (array, 4), 1
147 if (i > LBOUND (array, 4)) then
148 write(*, fmt="(A)", advance="no") " "
150 write(*, fmt="(A)", advance="no") "("
151 do j=LBOUND (array, 3), UBOUND (array, 3), 1
152 if (j > LBOUND (array, 3)) then
153 write(*, fmt="(A)", advance="no") " "
155 write(*, fmt="(A)", advance="no") "("
157 do k=LBOUND (array, 2), UBOUND (array, 2), 1
158 if (k > LBOUND (array, 2)) then
159 write(*, fmt="(A)", advance="no") " "
161 write(*, fmt="(A)", advance="no") "("
162 do l=LBOUND (array, 1), UBOUND (array, 1), 1
163 if (l > LBOUND (array, 1)) then
164 write(*, fmt="(A)", advance="no") ", "
166 write(*, fmt="(I0)", advance="no") array (l, k, j, i)
168 write(*, fmt="(A)", advance="no") ")"
170 write(*, fmt="(A)", advance="no") ")"
172 write(*, fmt="(A)", advance="no") ")"
174 write(*, fmt="(A)", advance="yes") ")"
176 print *, "" ! Display Array Slice 4D
177 end subroutine show_4d
180 ! Start of test program.
184 subroutine show_str (array)
185 character (len=*) :: array
186 end subroutine show_str
188 subroutine show_1d (array)
189 integer, dimension (:) :: array
190 end subroutine show_1d
192 subroutine show_2d (array)
193 integer, dimension(:,:) :: array
194 end subroutine show_2d
196 subroutine show_3d (array)
197 integer, dimension(:,:,:) :: array
198 end subroutine show_3d
200 subroutine show_4d (array)
201 integer, dimension(:,:,:,:) :: array
202 end subroutine show_4d
205 ! Declare variables used in this test.
206 integer, dimension (-10:-1,-10:-2) :: neg_array
207 integer, dimension (1:10,1:10) :: array
208 integer, allocatable :: other (:, :)
209 character (len=26) :: str_1 = "abcdefghijklmnopqrstuvwxyz"
210 integer, dimension (-2:2,-2:2,-2:2) :: array3d
211 integer, dimension (-3:3,7:10,-3:3,-10:-7) :: array4d
212 integer, dimension (10:20) :: array1d
213 integer, dimension(:,:), pointer :: pointer2d => null()
214 integer, dimension(-1:9,-1:9), target :: tarray
216 ! Allocate or associate any variables as needed.
217 allocate (other (-5:4, -2:7))
220 ! Fill arrays with contents ready for testing.
221 call fill_array_1d (array1d)
223 call fill_array_2d (neg_array)
224 call fill_array_2d (array)
225 call fill_array_2d (other)
226 call fill_array_2d (tarray)
228 call fill_array_3d (array3d)
229 call fill_array_4d (array4d)
231 ! The tests. Each call to a show_* function must have a unique set
232 ! of arguments as GDB uses the arguments are part of the test name
233 ! string, so duplicate arguments will result in duplicate test
236 ! If a show_* line ends with VARS=... where '...' is a comma
237 ! separated list of variable names, these variables are assumed to
238 ! be part of the call line, and will be expanded by the test script,
243 ! call show_1d (some_array (x,y)) ! VARS=x,y
247 ! In this example the test script will automatically expand 'x' and
248 ! 'y' in order to better test different aspects of GDB. Do take
249 ! care, the expansion is not very "smart", so try to avoid clashing
250 ! with other text on the line, in the example above, avoid variables
251 ! named 'some' or 'array', as these will likely clash with
253 call show_str (str_1)
254 call show_str (str_1 (1:20))
255 call show_str (str_1 (10:20))
257 call show_elem (array1d (11))
258 call show_elem (pointer2d (2,3))
260 call show_1d (array1d)
261 call show_1d (array1d (13:17))
262 call show_1d (array1d (17:13:-1))
263 call show_1d (array (1:5,1))
264 call show_1d (array4d (1,7,3,:))
265 call show_1d (pointer2d (-1:3, 2))
266 call show_1d (pointer2d (-1, 2:4))
268 ! Enclosing the array slice argument in (...) causess gfortran to
270 call show_1d ((array (1:5,1)))
272 call show_2d (pointer2d)
274 call show_2d (array (1:5,1:5))
277 call show_2d (array (1:10:i,1:10:j)) ! VARS=i,j
278 call show_2d (array (10:1:-i,1:10:j)) ! VARS=i,j
279 call show_2d (array (10:1:-i,10:1:-j)) ! VARS=i,j
280 call show_2d (array (1:10:i,10:1:-j)) ! VARS=i,j
283 call show_2d (array (6:2:-1,3:9))
284 call show_2d (array (1:10:2, 1:10:2))
286 call show_2d (other (-5:0, -2:0))
287 call show_2d (other (-5:4:2, -2:7:3))
288 call show_2d (neg_array)
289 call show_2d (neg_array (-10:-3,-8:-4:2))
291 ! Enclosing the array slice argument in (...) causess gfortran to
293 call show_2d ((array (1:10:3, 1:10:2)))
294 call show_2d ((neg_array (-10:-3,-8:-4:2)))
296 call show_3d (array3d)
297 call show_3d (array3d(-1:1,-1:1,-1:1))
298 call show_3d (array3d(1:-1:-1,1:-1:-1,1:-1:-1))
300 ! Enclosing the array slice argument in (...) causess gfortran to
302 call show_3d ((array3d(1:-1:-1,1:-1:-1,1:-1:-1)))
304 call show_4d (array4d)
305 call show_4d (array4d (-3:0,10:7:-1,0:3,-7:-10:-1))
306 call show_4d (array4d (3:0:-1, 10:7:-1, :, -7:-10:-1))
308 ! Enclosing the array slice argument in (...) causess gfortran to
310 call show_4d ((array4d (3:-2:-2, 10:7:-2, :, -7:-10:-1)))
312 ! All done. Deallocate.
315 ! GDB catches this final breakpoint to indicate the end of the test.
316 print *, "" ! Final Breakpoint.
320 ! Fill a 1D array with a unique positive integer in each element.
321 subroutine fill_array_1d (array)
322 integer, dimension (:) :: array
326 do j=LBOUND (array, 1), UBOUND (array, 1), 1
328 counter = counter + 1
330 end subroutine fill_array_1d
332 ! Fill a 2D array with a unique positive integer in each element.
333 subroutine fill_array_2d (array)
334 integer, dimension (:,:) :: array
338 do i=LBOUND (array, 2), UBOUND (array, 2), 1
339 do j=LBOUND (array, 1), UBOUND (array, 1), 1
340 array (j,i) = counter
341 counter = counter + 1
344 end subroutine fill_array_2d
346 ! Fill a 3D array with a unique positive integer in each element.
347 subroutine fill_array_3d (array)
348 integer, dimension (:,:,:) :: array
352 do i=LBOUND (array, 3), UBOUND (array, 3), 1
353 do j=LBOUND (array, 2), UBOUND (array, 2), 1
354 do k=LBOUND (array, 1), UBOUND (array, 1), 1
355 array (k, j,i) = counter
356 counter = counter + 1
360 end subroutine fill_array_3d
362 ! Fill a 4D array with a unique positive integer in each element.
363 subroutine fill_array_4d (array)
364 integer, dimension (:,:,:,:) :: array
368 do i=LBOUND (array, 4), UBOUND (array, 4), 1
369 do j=LBOUND (array, 3), UBOUND (array, 3), 1
370 do k=LBOUND (array, 2), UBOUND (array, 2), 1
371 do l=LBOUND (array, 1), UBOUND (array, 1), 1
372 array (l, k, j,i) = counter
373 counter = counter + 1
379 end subroutine fill_array_4d