Commit | Line | Data |
---|---|---|
88b9d363 | 1 | ! Copyright 2021-2022 Free Software Foundation, Inc. |
e92c8eb8 AB |
2 | ! |
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. | |
7 | ! | |
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. | |
12 | ! | |
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/>. | |
15 | ||
16 | #define DO_TEST(ARRAY) \ | |
17 | call do_test (lbound (ARRAY), ubound (ARRAY)) | |
18 | ||
19 | subroutine do_test (lb, ub) | |
20 | integer, dimension (:) :: lb | |
21 | integer, dimension (:) :: ub | |
22 | ||
23 | print *, "" | |
24 | print *, "Expected GDB Output:" | |
25 | print *, "" | |
26 | ||
27 | write(*, fmt="(A)", advance="no") "LBOUND = (" | |
28 | do i=LBOUND (lb, 1), UBOUND (lb, 1), 1 | |
29 | if (i > LBOUND (lb, 1)) then | |
30 | write(*, fmt="(A)", advance="no") ", " | |
31 | end if | |
32 | write(*, fmt="(I0)", advance="no") lb (i) | |
33 | end do | |
34 | write(*, fmt="(A)", advance="yes") ")" | |
35 | ||
36 | write(*, fmt="(A)", advance="no") "UBOUND = (" | |
37 | do i=LBOUND (ub, 1), UBOUND (ub, 1), 1 | |
38 | if (i > LBOUND (ub, 1)) then | |
39 | write(*, fmt="(A)", advance="no") ", " | |
40 | end if | |
41 | write(*, fmt="(I0)", advance="no") ub (i) | |
42 | end do | |
43 | write(*, fmt="(A)", advance="yes") ")" | |
44 | ||
45 | print *, "" ! Test Breakpoint | |
46 | end subroutine do_test | |
47 | ||
48 | ! | |
49 | ! Start of test program. | |
50 | ! | |
51 | program test | |
52 | interface | |
53 | subroutine do_test (lb, ub) | |
54 | integer, dimension (:) :: lb | |
55 | integer, dimension (:) :: ub | |
56 | end subroutine do_test | |
57 | end interface | |
58 | ||
59 | ! Declare variables used in this test. | |
60 | integer, dimension (-8:-1,-10:-2) :: neg_array | |
61 | integer, dimension (2:10,1:9), target :: array | |
62 | integer, allocatable :: other (:, :) | |
63 | character (len=26) :: str_1 = "abcdefghijklmnopqrstuvwxyz" | |
64 | integer, dimension (-2:2,-3:3,-1:5) :: array3d | |
65 | integer, dimension (-3:3,7:10,-4:2,-10:-7) :: array4d | |
66 | integer, dimension (10:20) :: array1d | |
67 | integer, dimension(:,:), pointer :: pointer2d => null() | |
68 | integer, dimension(-2:6,-1:9), target :: tarray | |
69 | integer :: an_int | |
70 | ||
71 | integer, dimension (:), pointer :: pointer1d => null() | |
72 | ||
73 | ! Allocate or associate any variables as needed. | |
74 | allocate (other (-5:4, -2:7)) | |
75 | pointer2d => tarray | |
76 | pointer1d => array (3, 2:5) | |
77 | ||
78 | DO_TEST (neg_array) | |
79 | DO_TEST (neg_array (-7:-3,-5:-4)) | |
80 | DO_TEST (array) | |
81 | ! The following is disabled due to a bug in gfortran: | |
82 | ! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=99027 | |
83 | ! gfortran generates the incorrect expected results. | |
84 | ! DO_TEST (array (3, 2:5)) | |
85 | DO_TEST (pointer1d) | |
86 | DO_TEST (other) | |
87 | DO_TEST (array3d) | |
88 | DO_TEST (array4d) | |
89 | DO_TEST (array1d) | |
90 | DO_TEST (pointer2d) | |
91 | DO_TEST (tarray) | |
92 | ||
93 | ! All done. Deallocate. | |
94 | deallocate (other) | |
95 | ||
96 | ! GDB catches this final breakpoint to indicate the end of the test. | |
97 | print *, "" ! Final Breakpoint. | |
98 | ||
99 | ! Reference otherwise unused locals in order to keep them around. | |
100 | ! GDB will make use of these for some tests. | |
101 | print *, str_1 | |
102 | an_int = 1 | |
103 | print *, an_int | |
104 | ||
105 | end program test |