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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
|
# Copyright 2021 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/> .
# Testing GDB's implementation of LBOUND and UBOUND.
if {[skip_fortran_tests]} { return -1 }
standard_testfile ".F90"
load_lib fortran.exp
if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
{debug f90}]} {
return -1
}
if ![fortran_runto_main] {
untested "could not run to main"
return -1
}
gdb_breakpoint [gdb_get_line_number "Test Breakpoint"]
gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
set found_final_breakpoint false
# We place a limit on the number of tests that can be run, just in
# case something goes wrong, and GDB gets stuck in an loop here.
set test_count 0
while { $test_count < 500 } {
with_test_prefix "test $test_count" {
incr test_count
set expected_lbound ""
set expected_ubound ""
gdb_test_multiple "continue" "continue" {
-re ".*LBOUND = (\[^\r\n\]+)\r\n" {
set expected_lbound $expect_out(1,string)
exp_continue
}
-re ".*UBOUND = (\[^\r\n\]+)\r\n" {
set expected_ubound $expect_out(1,string)
exp_continue
}
-re "! Test Breakpoint" {
set func_name "show_elem"
exp_continue
}
-re "! Final Breakpoint" {
set found_final_breakpoint true
exp_continue
}
-re "$gdb_prompt $" {
# We're done.
}
}
if ($found_final_breakpoint) {
break
}
verbose -log "APB: Run a test here"
verbose -log "APB: Expected lbound '$expected_lbound'"
verbose -log "APB: Expected ubound '$expected_ubound'"
# We want to take a look at the line in the previous frame that
# called the current function. I couldn't find a better way of
# doing this than 'up', which will print the line, then 'down'
# again.
#
# I don't want to fill the log with passes for these up/down
# commands, so we don't report any. If something goes wrong then we
# should get a fail from gdb_test_multiple.
set array_name ""
set xfail_data ""
gdb_test_multiple "up" "up" {
-re "\r\n\[0-9\]+\[ \t\]+DO_TEST \\((\[^\r\n\]+)\\)\r\n$gdb_prompt $" {
set array_name $expect_out(1,string)
}
}
# Check we have all the information we need to successfully run one
# of these tests.
if { $expected_lbound == "" } {
perror "failed to extract expected results for lbound"
return 0
}
if { $expected_ubound == "" } {
perror "failed to extract expected results for ubound"
return 0
}
if { $array_name == "" } {
perror "failed to extract array name"
return 0
}
# Check GDB can correctly print complete set of upper and
# lower bounds for an array.
set pattern [string_to_regexp " = $expected_lbound"]
gdb_test "p lbound ($array_name)" "$pattern" \
"check value of lbound ('$array_name') expression"
set pattern [string_to_regexp " = $expected_ubound"]
gdb_test "p ubound ($array_name)" "$pattern" \
"check value of ubound ('$array_name') expression"
# Now ask for each bound in turn and check it against the
# expected results.
#
# First ask for bound 0. This should fail, but will also tell
# us the actual bounds of the array. Thanks GDB.
set upper_dim ""
gdb_test_multiple "p lbound ($array_name, 0)" "" {
-re "\r\nLBOUND dimension must be from 1 to (\[0-9\]+)\r\n$gdb_prompt $" {
set upper_dim $expect_out(1,string)
}
}
gdb_assert { ![string eq $upper_dim ""] } \
"extracted the upper dimension value"
# Check that asking for the ubound dimension 0 gives the same
# dimension range as in the lbound case.
gdb_test_multiple "p ubound ($array_name, 0)" "" {
-re "\r\nUBOUND dimension must be from 1 to (\[0-9\]+)\r\n$gdb_prompt $" {
gdb_assert {$upper_dim == $expect_out(1,string)} \
"ubound limit matches lbound limit"
}
}
# Now ask for the upper and lower bound for each dimension in
# turn. Add these results into a string which, when complete,
# will look like the expected results seen above.
set lbound_str ""
set ubound_str ""
set prefix "("
for { set i 1 } { $i <= $upper_dim } { incr i } {
set v [get_valueof "/d" "lbound ($array_name, $i)" "???"]
set lbound_str "${lbound_str}${prefix}${v}"
set v [get_valueof "/d" "ubound ($array_name, $i)" "???"]
set ubound_str "${ubound_str}${prefix}${v}"
set prefix ", "
}
# Add closing parenthesis.
set lbound_str "${lbound_str})"
set ubound_str "${ubound_str})"
gdb_assert [string eq ${lbound_str} $expected_lbound] \
"lbounds match"
gdb_assert [string eq ${ubound_str} $expected_ubound] \
"ubounds match"
# Finally, check that asking for a dimension above the valid
# range gives the expected error.
set bad_dim [expr $upper_dim + 1]
gdb_test "p lbound ($array_name, $bad_dim)" \
"LBOUND dimension must be from 1 to $upper_dim" \
"check error message for lbound of dim = $bad_dim"
gdb_test "p ubound ($array_name, $bad_dim)" \
"UBOUND dimension must be from 1 to $upper_dim" \
"check error message for ubound of dim = $bad_dim"
# Move back up a frame just so we finish the test in frame 0.
gdb_test_multiple "down" "down" {
-re "\r\n$gdb_prompt $" {
# Don't issue a pass here.
}
}
}
}
# Ensure we reached the final breakpoint. If more tests have been added
# to the test script, and this starts failing, then the safety 'while'
# loop above might need to be increased.
gdb_assert {$found_final_breakpoint} "reached final breakpoint"
# Now for some final tests. This is mostly testing that GDB gives the
# correct errors in certain cases.
foreach var {str_1 an_int} {
foreach func {lbound ubound} {
gdb_test "p ${func} ($var)" \
"[string toupper $func] can only be applied to arrays"
}
}
|
