1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
|
! Copyright 2021-2022 Free Software Foundation, Inc.
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program. If not, see <http://www.gnu.org/licenses/>.
#define DO_TEST(ARRAY) \
call do_test (lbound (ARRAY), ubound (ARRAY))
subroutine do_test (lb, ub)
integer*4, dimension (:) :: lb
integer*4, dimension (:) :: ub
print *, ""
print *, "Expected GDB Output:"
print *, ""
write(*, fmt="(A)", advance="no") "LBOUND = ("
do i=LBOUND (lb, 1), UBOUND (lb, 1), 1
if (i > LBOUND (lb, 1)) then
write(*, fmt="(A)", advance="no") ", "
end if
write(*, fmt="(I0)", advance="no") lb (i)
end do
write(*, fmt="(A)", advance="yes") ")"
write(*, fmt="(A)", advance="no") "UBOUND = ("
do i=LBOUND (ub, 1), UBOUND (ub, 1), 1
if (i > LBOUND (ub, 1)) then
write(*, fmt="(A)", advance="no") ", "
end if
write(*, fmt="(I0)", advance="no") ub (i)
end do
write(*, fmt="(A)", advance="yes") ")"
print *, "" ! Test Breakpoint
end subroutine do_test
!
! Start of test program.
!
program test
interface
subroutine do_test (lb, ub)
integer*4, dimension (:) :: lb
integer*4, dimension (:) :: ub
end subroutine do_test
end interface
! Declare variables used in this test.
integer, dimension (-8:-1,-10:-2) :: neg_array
integer, dimension (2:10,1:9), target :: array
integer, allocatable :: other (:, :)
character (len=26) :: str_1 = "abcdefghijklmnopqrstuvwxyz"
integer, dimension (-2:2,-3:3,-1:5) :: array3d
integer, dimension (-3:3,7:10,-4:2,-10:-7) :: array4d
integer, dimension (10:20) :: array1d
integer, dimension(:,:), pointer :: pointer2d => null()
integer, dimension(-2:6,-1:9), target :: tarray
integer :: an_int
integer, dimension (:), pointer :: pointer1d => null()
integer, parameter :: b1 = 127 - 10
integer, parameter :: b1_o = 127 + 2
integer, parameter :: b2 = 32767 - 10
integer, parameter :: b2_o = 32767 + 3
integer*8, parameter :: b4 = 2147483647 - 10
integer*8, parameter :: b4_o = 2147483647 + 5
integer, allocatable :: array_1d_1bytes_overflow (:)
integer, allocatable :: array_1d_2bytes_overflow (:)
integer, allocatable :: array_1d_4bytes_overflow (:)
integer, allocatable :: array_2d_1byte_overflow (:,:)
integer, allocatable :: array_2d_2bytes_overflow (:,:)
integer, allocatable :: array_3d_1byte_overflow (:,:,:)
! Allocate or associate any variables as needed.
allocate (other (-5:4, -2:7))
pointer2d => tarray
pointer1d => array (3, 2:5)
allocate (array_1d_1bytes_overflow (-b1_o:-b1))
allocate (array_1d_2bytes_overflow (b2:b2_o))
allocate (array_1d_4bytes_overflow (-b4_o:-b4))
allocate (array_2d_1byte_overflow (-b1_o:-b1,b1:b1_o))
allocate (array_2d_2bytes_overflow (b2:b2_o,-b2_o:b2))
allocate (array_3d_1byte_overflow (-b1_o:-b1,b1:b1_o,-b1_o:-b1))
DO_TEST (neg_array)
DO_TEST (neg_array (-7:-3,-5:-4))
DO_TEST (array)
! The following is disabled due to a bug in gfortran:
! https://gcc.gnu.org/bugzilla/show_bug.cgi?id=99027
! gfortran generates the incorrect expected results.
! DO_TEST (array (3, 2:5))
DO_TEST (pointer1d)
DO_TEST (other)
DO_TEST (array3d)
DO_TEST (array4d)
DO_TEST (array1d)
DO_TEST (pointer2d)
DO_TEST (tarray)
DO_TEST (array_1d_1bytes_overflow)
DO_TEST (array_1d_2bytes_overflow)
DO_TEST (array_1d_4bytes_overflow)
DO_TEST (array_2d_1byte_overflow)
DO_TEST (array_2d_2bytes_overflow)
DO_TEST (array_3d_1byte_overflow)
! All done. Deallocate.
print *, "" ! Breakpoint before deallocate.
deallocate (other)
deallocate (array_3d_1byte_overflow)
deallocate (array_2d_2bytes_overflow)
deallocate (array_2d_1byte_overflow)
deallocate (array_1d_4bytes_overflow)
deallocate (array_1d_2bytes_overflow)
deallocate (array_1d_1bytes_overflow)
! GDB catches this final breakpoint to indicate the end of the test.
print *, "" ! Final Breakpoint.
! Reference otherwise unused locals in order to keep them around.
! GDB will make use of these for some tests.
print *, str_1
an_int = 1
print *, an_int
end program test
|
