]>
Commit | Line | Data |
---|---|---|
213516ef | 1 | # Copyright 2021-2023 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 | ||
e92c8eb8 AB |
16 | # Testing GDB's implementation of LBOUND and UBOUND. |
17 | ||
18 | if {[skip_fortran_tests]} { return -1 } | |
19 | ||
20 | standard_testfile ".F90" | |
21 | load_lib fortran.exp | |
22 | ||
23 | if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \ | |
24 | {debug f90}]} { | |
25 | return -1 | |
26 | } | |
27 | ||
c8ed8c8a TV |
28 | # Avoid shared lib symbols. |
29 | gdb_test_no_output "set auto-solib-add off" | |
e92c8eb8 AB |
30 | |
31 | if ![fortran_runto_main] { | |
e92c8eb8 AB |
32 | return -1 |
33 | } | |
34 | ||
9bde221f PA |
35 | # This test relies on output from the inferior. |
36 | if [target_info exists gdb,noinferiorio] { | |
e0083052 KS |
37 | return 0 |
38 | } | |
39 | ||
c8ed8c8a TV |
40 | # Avoid libc symbols, in particular the 'array' type. |
41 | gdb_test_no_output "nosharedlibrary" | |
42 | ||
e92c8eb8 | 43 | gdb_breakpoint [gdb_get_line_number "Test Breakpoint"] |
891e4190 | 44 | gdb_breakpoint [gdb_get_line_number "Breakpoint before deallocate\."] |
e92c8eb8 AB |
45 | gdb_breakpoint [gdb_get_line_number "Final Breakpoint"] |
46 | ||
891e4190 | 47 | set found_dealloc_breakpoint false |
e92c8eb8 AB |
48 | |
49 | # We place a limit on the number of tests that can be run, just in | |
50 | # case something goes wrong, and GDB gets stuck in an loop here. | |
51 | set test_count 0 | |
52 | while { $test_count < 500 } { | |
53 | with_test_prefix "test $test_count" { | |
54 | incr test_count | |
55 | ||
56 | set expected_lbound "" | |
57 | set expected_ubound "" | |
9bde221f | 58 | set found_prompt false |
e92c8eb8 | 59 | gdb_test_multiple "continue" "continue" { |
9bde221f PA |
60 | -i $::inferior_spawn_id |
61 | ||
e92c8eb8 AB |
62 | -re ".*LBOUND = (\[^\r\n\]+)\r\n" { |
63 | set expected_lbound $expect_out(1,string) | |
9bde221f PA |
64 | if {!$found_prompt} { |
65 | exp_continue | |
66 | } | |
e92c8eb8 AB |
67 | } |
68 | -re ".*UBOUND = (\[^\r\n\]+)\r\n" { | |
69 | set expected_ubound $expect_out(1,string) | |
9bde221f PA |
70 | if {!$found_prompt} { |
71 | exp_continue | |
72 | } | |
e92c8eb8 | 73 | } |
9bde221f PA |
74 | |
75 | -i $::gdb_spawn_id | |
76 | ||
e92c8eb8 AB |
77 | -re "! Test Breakpoint" { |
78 | set func_name "show_elem" | |
79 | exp_continue | |
80 | } | |
891e4190 NCK |
81 | -re "! Breakpoint before deallocate" { |
82 | set found_dealloc_breakpoint true | |
e92c8eb8 AB |
83 | exp_continue |
84 | } | |
85 | -re "$gdb_prompt $" { | |
9bde221f PA |
86 | set found_prompt true |
87 | ||
891e4190 | 88 | if {$found_dealloc_breakpoint |
9bde221f PA |
89 | || ($expected_lbound != "" && $expected_ubound != "")} { |
90 | # We're done. | |
91 | } else { | |
92 | exp_continue | |
93 | } | |
e92c8eb8 AB |
94 | } |
95 | } | |
96 | ||
891e4190 | 97 | if ($found_dealloc_breakpoint) { |
e92c8eb8 AB |
98 | break |
99 | } | |
100 | ||
101 | verbose -log "APB: Run a test here" | |
102 | verbose -log "APB: Expected lbound '$expected_lbound'" | |
103 | verbose -log "APB: Expected ubound '$expected_ubound'" | |
104 | ||
105 | # We want to take a look at the line in the previous frame that | |
106 | # called the current function. I couldn't find a better way of | |
107 | # doing this than 'up', which will print the line, then 'down' | |
108 | # again. | |
109 | # | |
110 | # I don't want to fill the log with passes for these up/down | |
111 | # commands, so we don't report any. If something goes wrong then we | |
112 | # should get a fail from gdb_test_multiple. | |
113 | set array_name "" | |
114 | set xfail_data "" | |
115 | gdb_test_multiple "up" "up" { | |
116 | -re "\r\n\[0-9\]+\[ \t\]+DO_TEST \\((\[^\r\n\]+)\\)\r\n$gdb_prompt $" { | |
117 | set array_name $expect_out(1,string) | |
118 | } | |
119 | } | |
120 | ||
121 | # Check we have all the information we need to successfully run one | |
122 | # of these tests. | |
123 | if { $expected_lbound == "" } { | |
124 | perror "failed to extract expected results for lbound" | |
125 | return 0 | |
126 | } | |
127 | if { $expected_ubound == "" } { | |
128 | perror "failed to extract expected results for ubound" | |
129 | return 0 | |
130 | } | |
131 | if { $array_name == "" } { | |
132 | perror "failed to extract array name" | |
133 | return 0 | |
134 | } | |
135 | ||
136 | # Check GDB can correctly print complete set of upper and | |
137 | # lower bounds for an array. | |
138 | set pattern [string_to_regexp " = $expected_lbound"] | |
139 | gdb_test "p lbound ($array_name)" "$pattern" \ | |
140 | "check value of lbound ('$array_name') expression" | |
141 | set pattern [string_to_regexp " = $expected_ubound"] | |
142 | gdb_test "p ubound ($array_name)" "$pattern" \ | |
143 | "check value of ubound ('$array_name') expression" | |
144 | ||
145 | # Now ask for each bound in turn and check it against the | |
146 | # expected results. | |
147 | # | |
148 | # First ask for bound 0. This should fail, but will also tell | |
149 | # us the actual bounds of the array. Thanks GDB. | |
150 | set upper_dim "" | |
151 | gdb_test_multiple "p lbound ($array_name, 0)" "" { | |
152 | -re "\r\nLBOUND dimension must be from 1 to (\[0-9\]+)\r\n$gdb_prompt $" { | |
153 | set upper_dim $expect_out(1,string) | |
154 | } | |
155 | } | |
156 | ||
157 | gdb_assert { ![string eq $upper_dim ""] } \ | |
158 | "extracted the upper dimension value" | |
159 | ||
160 | # Check that asking for the ubound dimension 0 gives the same | |
161 | # dimension range as in the lbound case. | |
162 | gdb_test_multiple "p ubound ($array_name, 0)" "" { | |
163 | -re "\r\nUBOUND dimension must be from 1 to (\[0-9\]+)\r\n$gdb_prompt $" { | |
164 | gdb_assert {$upper_dim == $expect_out(1,string)} \ | |
165 | "ubound limit matches lbound limit" | |
166 | } | |
167 | } | |
168 | ||
169 | # Now ask for the upper and lower bound for each dimension in | |
170 | # turn. Add these results into a string which, when complete, | |
171 | # will look like the expected results seen above. | |
172 | set lbound_str "" | |
173 | set ubound_str "" | |
174 | set prefix "(" | |
175 | for { set i 1 } { $i <= $upper_dim } { incr i } { | |
176 | set v [get_valueof "/d" "lbound ($array_name, $i)" "???"] | |
177 | set lbound_str "${lbound_str}${prefix}${v}" | |
178 | ||
179 | set v [get_valueof "/d" "ubound ($array_name, $i)" "???"] | |
180 | set ubound_str "${ubound_str}${prefix}${v}" | |
181 | ||
182 | set prefix ", " | |
183 | } | |
184 | ||
185 | # Add closing parenthesis. | |
186 | set lbound_str "${lbound_str})" | |
187 | set ubound_str "${ubound_str})" | |
188 | ||
189 | gdb_assert [string eq ${lbound_str} $expected_lbound] \ | |
190 | "lbounds match" | |
191 | gdb_assert [string eq ${ubound_str} $expected_ubound] \ | |
192 | "ubounds match" | |
193 | ||
194 | # Finally, check that asking for a dimension above the valid | |
195 | # range gives the expected error. | |
196 | set bad_dim [expr $upper_dim + 1] | |
197 | gdb_test "p lbound ($array_name, $bad_dim)" \ | |
198 | "LBOUND dimension must be from 1 to $upper_dim" \ | |
199 | "check error message for lbound of dim = $bad_dim" | |
200 | ||
201 | gdb_test "p ubound ($array_name, $bad_dim)" \ | |
202 | "UBOUND dimension must be from 1 to $upper_dim" \ | |
203 | "check error message for ubound of dim = $bad_dim" | |
204 | ||
205 | # Move back up a frame just so we finish the test in frame 0. | |
206 | gdb_test_multiple "down" "down" { | |
207 | -re "\r\n$gdb_prompt $" { | |
208 | # Don't issue a pass here. | |
209 | } | |
210 | } | |
211 | } | |
212 | } | |
213 | ||
891e4190 NCK |
214 | gdb_assert {$found_dealloc_breakpoint} "ran all compiled in tests" |
215 | ||
216 | # Test the kind parameter of ubound and lbound a few times. | |
217 | gdb_test "p lbound(array_1d_1bytes_overflow, 1, 1)" "= 127" | |
218 | gdb_test "p lbound(array_1d_1bytes_overflow, 1, 2)" "= -129" | |
219 | gdb_test "p ubound(array_1d_1bytes_overflow, 1, 1)" "= -117" | |
220 | ||
221 | gdb_test "p lbound(array_1d_2bytes_overflow, 1, 2)" "= 32757" | |
222 | gdb_test "p ubound(array_1d_2bytes_overflow, 1, 2)" "= -32766" | |
223 | gdb_test "p ubound(array_1d_2bytes_overflow, 1, 4)" "= 32770" | |
224 | ||
6dc7160b NCK |
225 | # On 32-bit machines most compilers will complain when trying to allocate an |
226 | # array with ranges outside the 4 byte integer range. As the behavior is | |
227 | # compiler implementation dependent, we do not run these test on 32 bit targets. | |
228 | if {[is_64_target]} { | |
229 | gdb_test "p lbound(array_1d_4bytes_overflow, 1, 4)" "= 2147483644" | |
230 | gdb_test "p lbound(array_1d_4bytes_overflow, 1, 8)" "= -2147483652" | |
231 | gdb_test "p ubound(array_1d_4bytes_overflow, 1, 4)" "= -2147483637" | |
232 | gdb_test "p lbound(array_1d_4bytes_overflow)" "= \\(2147483644\\)" | |
233 | } | |
891e4190 | 234 | |
e92c8eb8 AB |
235 | # Ensure we reached the final breakpoint. If more tests have been added |
236 | # to the test script, and this starts failing, then the safety 'while' | |
237 | # loop above might need to be increased. | |
891e4190 | 238 | gdb_continue_to_breakpoint "Final Breakpoint" |
e92c8eb8 AB |
239 | |
240 | # Now for some final tests. This is mostly testing that GDB gives the | |
241 | # correct errors in certain cases. | |
242 | foreach var {str_1 an_int} { | |
243 | foreach func {lbound ubound} { | |
244 | gdb_test "p ${func} ($var)" \ | |
245 | "[string toupper $func] can only be applied to arrays" | |
246 | } | |
247 | } |