]>
Commit | Line | Data |
---|---|---|
1d506c26 | 1 | # Copyright 2019-2024 Free Software Foundation, Inc. |
5bbd8269 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 | # Print a 2 dimensional assumed shape array. We pass different slices | |
33b5899f | 17 | # of the array to a subroutine and print the array as received within |
5bbd8269 AB |
18 | # the subroutine. This should exercise GDB's ability to handle |
19 | # different strides for the different dimensions. | |
20 | ||
a5c641b5 AB |
21 | # Testing GDB's ability to print array (and string) slices, including |
22 | # slices that make use of array strides. | |
23 | # | |
24 | # In the Fortran code various arrays of different ranks are filled | |
25 | # with data, and slices are passed to a series of show functions. | |
26 | # | |
27 | # In this test script we break in each of the show functions, print | |
28 | # the array slice that was passed in, and then move up the stack to | |
29 | # the parent frame and check GDB can manually extract the same slice. | |
30 | # | |
31 | # This test also checks that the size of the array slice passed to the | |
32 | # function (so as extracted and described by the compiler and the | |
33 | # debug information) matches the size of the slice manually extracted | |
34 | # by GDB. | |
35 | ||
57b7402d | 36 | require allow_fortran_tests |
5bbd8269 | 37 | |
9bde221f | 38 | # This test relies on output from the inferior. |
450d26c8 | 39 | require {!target_info exists gdb,noinferiorio} |
9bde221f | 40 | |
5bbd8269 | 41 | standard_testfile ".f90" |
86cd6bc8 | 42 | load_lib fortran.exp |
5bbd8269 | 43 | |
98bf5c02 | 44 | if {[build_executable ${testfile}.exp ${testfile} ${srcfile} \ |
5bbd8269 AB |
45 | {debug f90}]} { |
46 | return -1 | |
47 | } | |
48 | ||
a5c641b5 AB |
49 | # Takes the name of an array slice as used in the test source, and extracts |
50 | # the base array name. For example: 'array (1,2)' becomes 'array'. | |
51 | proc array_slice_to_var { slice_str } { | |
52 | regexp "^(?:\\s*\\()*(\[^( \t\]+)" $slice_str matchvar varname | |
53 | return $varname | |
5bbd8269 AB |
54 | } |
55 | ||
a5c641b5 AB |
56 | proc run_test { repack } { |
57 | global binfile gdb_prompt | |
58 | ||
59 | clean_restart ${binfile} | |
60 | ||
c8ed8c8a TV |
61 | # Avoid shared lib symbols. |
62 | gdb_test_no_output "set auto-solib-add off" | |
63 | ||
a5c641b5 | 64 | if ![fortran_runto_main] { |
a5c641b5 | 65 | return -1 |
5bbd8269 | 66 | } |
5bbd8269 | 67 | |
c8ed8c8a TV |
68 | # Avoid libc symbols, in particular the 'array' type. |
69 | gdb_test_no_output "nosharedlibrary" | |
70 | ||
a5c641b5 AB |
71 | gdb_test_no_output "set fortran repack-array-slices $repack" |
72 | ||
73 | # gdb_breakpoint [gdb_get_line_number "Display Message Breakpoint"] | |
74 | gdb_breakpoint [gdb_get_line_number "Display Element"] | |
75 | gdb_breakpoint [gdb_get_line_number "Display String"] | |
76 | gdb_breakpoint [gdb_get_line_number "Display Array Slice 1D"] | |
77 | gdb_breakpoint [gdb_get_line_number "Display Array Slice 2D"] | |
78 | gdb_breakpoint [gdb_get_line_number "Display Array Slice 3D"] | |
79 | gdb_breakpoint [gdb_get_line_number "Display Array Slice 4D"] | |
80 | gdb_breakpoint [gdb_get_line_number "Final Breakpoint"] | |
81 | ||
82 | # We're going to print some reasonably large arrays. | |
83 | gdb_test_no_output "set print elements unlimited" | |
84 | ||
85 | set found_final_breakpoint false | |
86 | ||
87 | # We place a limit on the number of tests that can be run, just in | |
88 | # case something goes wrong, and GDB gets stuck in an loop here. | |
89 | set test_count 0 | |
90 | while { $test_count < 500 } { | |
91 | with_test_prefix "test $test_count" { | |
92 | incr test_count | |
93 | ||
94 | set found_final_breakpoint false | |
95 | set expected_result "" | |
96 | set func_name "" | |
9bde221f | 97 | set found_prompt false |
a5c641b5 | 98 | gdb_test_multiple "continue" "continue" { |
9bde221f PA |
99 | -i $::inferior_spawn_id |
100 | ||
a5c641b5 AB |
101 | -re ".*GDB = (\[^\r\n\]+)\r\n" { |
102 | set expected_result $expect_out(1,string) | |
9bde221f PA |
103 | if {!$found_prompt} { |
104 | exp_continue | |
105 | } | |
a5c641b5 | 106 | } |
9bde221f PA |
107 | |
108 | -i $::gdb_spawn_id | |
109 | ||
a5c641b5 AB |
110 | -re "! Display Element" { |
111 | set func_name "show_elem" | |
112 | exp_continue | |
113 | } | |
114 | -re "! Display String" { | |
115 | set func_name "show_str" | |
116 | exp_continue | |
117 | } | |
118 | -re "! Display Array Slice (.)D" { | |
119 | set func_name "show_$expect_out(1,string)d" | |
120 | exp_continue | |
121 | } | |
122 | -re "! Final Breakpoint" { | |
123 | set found_final_breakpoint true | |
124 | exp_continue | |
125 | } | |
126 | -re "$gdb_prompt $" { | |
9bde221f PA |
127 | set found_prompt true |
128 | ||
129 | if {$found_final_breakpoint | |
130 | || ($expected_result != "" && $func_name != "")} { | |
131 | # We're done. | |
132 | } else { | |
133 | exp_continue | |
134 | } | |
a5c641b5 AB |
135 | } |
136 | } | |
6b4c676c | 137 | |
a5c641b5 AB |
138 | if ($found_final_breakpoint) { |
139 | break | |
140 | } | |
6b4c676c | 141 | |
a5c641b5 AB |
142 | # We want to take a look at the line in the previous frame that |
143 | # called the current function. I couldn't find a better way of | |
144 | # doing this than 'up', which will print the line, then 'down' | |
145 | # again. | |
146 | # | |
147 | # I don't want to fill the log with passes for these up/down | |
148 | # commands, so we don't report any. If something goes wrong then we | |
149 | # should get a fail from gdb_test_multiple. | |
150 | set array_slice_name "" | |
151 | set unique_id "" | |
152 | array unset replacement_vars | |
153 | array set replacement_vars {} | |
154 | gdb_test_multiple "up" "up" { | |
155 | -re "\r\n\[0-9\]+\[ \t\]+call ${func_name} \\((\[^\r\n\]+)\\)\r\n$gdb_prompt $" { | |
156 | set array_slice_name $expect_out(1,string) | |
157 | } | |
158 | -re "\r\n\[0-9\]+\[ \t\]+call ${func_name} \\((\[^\r\n\]+)\\)\[ \t\]+! VARS=(\[^ \t\r\n\]+)\r\n$gdb_prompt $" { | |
159 | set array_slice_name $expect_out(1,string) | |
160 | set unique_id $expect_out(2,string) | |
161 | } | |
162 | } | |
163 | if {$unique_id != ""} { | |
164 | set str "" | |
165 | foreach v [split $unique_id ,] { | |
166 | set val [get_integer_valueof "${v}" "??"\ | |
167 | "get variable '$v' for '$array_slice_name'"] | |
168 | set replacement_vars($v) $val | |
169 | if {$str != ""} { | |
170 | set str "Str," | |
171 | } | |
172 | set str "$str$v=$val" | |
173 | } | |
174 | set unique_id " $str" | |
175 | } | |
176 | gdb_test_multiple "down" "down" { | |
177 | -re "\r\n$gdb_prompt $" { | |
178 | # Don't issue a pass here. | |
179 | } | |
180 | } | |
181 | ||
182 | # Check we have all the information we need to successfully run one | |
183 | # of these tests. | |
184 | if { $expected_result == "" } { | |
185 | perror "failed to extract expected results" | |
186 | return 0 | |
187 | } | |
188 | if { $array_slice_name == "" } { | |
189 | perror "failed to extract array slice name" | |
190 | return 0 | |
191 | } | |
192 | ||
193 | # Check GDB can correctly print the array slice that was passed into | |
194 | # the current frame. | |
195 | set pattern [string_to_regexp " = $expected_result"] | |
196 | gdb_test "p array" "$pattern" \ | |
197 | "check value of '$array_slice_name'$unique_id" | |
198 | ||
199 | # Get the size of the slice. | |
200 | set size_in_show \ | |
201 | [get_integer_valueof "sizeof (array)" "show_unknown" \ | |
202 | "get sizeof '$array_slice_name'$unique_id in show"] | |
203 | set addr_in_show \ | |
204 | [get_hexadecimal_valueof "&array" "show_unknown" \ | |
205 | "get address '$array_slice_name'$unique_id in show"] | |
206 | ||
207 | # Now move into the previous frame, and see if GDB can extract the | |
208 | # array slice from the original parent object. Again, use of | |
209 | # gdb_test_multiple to avoid filling the logs with unnecessary | |
210 | # passes. | |
211 | gdb_test_multiple "up" "up" { | |
212 | -re "\r\n$gdb_prompt $" { | |
213 | # Do nothing. | |
214 | } | |
215 | } | |
216 | ||
217 | # Print the array slice, this will force GDB to manually extract the | |
218 | # slice from the parent array. | |
219 | gdb_test "p $array_slice_name" "$pattern" \ | |
220 | "check array slice '$array_slice_name'$unique_id can be extracted" | |
221 | ||
222 | # Get the size of the slice in the calling frame. | |
223 | set size_in_parent \ | |
224 | [get_integer_valueof "sizeof ($array_slice_name)" \ | |
225 | "parent_unknown" \ | |
226 | "get sizeof '$array_slice_name'$unique_id in parent"] | |
227 | ||
228 | # Figure out the start and end addresses of the full array in the | |
229 | # parent frame. | |
230 | set full_var_name [array_slice_to_var $array_slice_name] | |
231 | set start_addr [get_hexadecimal_valueof "&${full_var_name}" \ | |
232 | "start unknown"] | |
233 | set end_addr [get_hexadecimal_valueof \ | |
10f92414 | 234 | "$start_addr + sizeof (${full_var_name})" \ |
02baa133 AB |
235 | "end unknown" \ |
236 | "get end address of ${full_var_name}"] | |
a5c641b5 AB |
237 | |
238 | # The Fortran compiler can choose to either send a descriptor that | |
239 | # describes the array slice to the subroutine, or it can repack the | |
240 | # slice into an array section and send that. | |
241 | # | |
242 | # We find the address range of the original array in the parent, | |
243 | # and the address of the slice in the show function, if the | |
244 | # address of the slice (from show) is in the range of the original | |
245 | # array then repacking has not occurred, otherwise, the slice is | |
246 | # outside of the parent, and repacking must have occurred. | |
247 | # | |
248 | # The goal here is to compare the sizes of the slice in show with | |
249 | # the size of the slice extracted by GDB. So we can only compare | |
250 | # sizes when GDB's repacking setting matches the repacking | |
251 | # behaviour we got from the compiler. | |
252 | if { ($addr_in_show < $start_addr || $addr_in_show >= $end_addr) \ | |
253 | == ($repack == "on") } { | |
254 | gdb_assert {$size_in_show == $size_in_parent} \ | |
255 | "check sizes match" | |
256 | } elseif { $repack == "off" } { | |
257 | # GDB's repacking is off (so slices are left unpacked), but | |
258 | # the compiler did pack this one. As a result we can't | |
259 | # compare the sizes between the compiler's slice and GDB's | |
260 | # slice. | |
261 | verbose -log "slice '$array_slice_name' was repacked, sizes can't be compared" | |
262 | } else { | |
263 | # Like the above, but the reverse, GDB's repacking is on, but | |
264 | # the compiler didn't repack this slice. | |
265 | verbose -log "slice '$array_slice_name' was not repacked, sizes can't be compared" | |
266 | } | |
267 | ||
268 | # If the array name we just tested included variable names, then | |
269 | # test again with all the variables expanded. | |
270 | if {$unique_id != ""} { | |
271 | foreach v [array names replacement_vars] { | |
272 | set val $replacement_vars($v) | |
273 | set array_slice_name \ | |
274 | [regsub "\\y${v}\\y" $array_slice_name $val] | |
275 | } | |
276 | gdb_test "p $array_slice_name" "$pattern" \ | |
277 | "check array slice '$array_slice_name'$unique_id can be extracted, with variables expanded" | |
278 | } | |
279 | } | |
280 | } | |
281 | ||
282 | # Ensure we reached the final breakpoint. If more tests have been added | |
283 | # to the test script, and this starts failing, then the safety 'while' | |
284 | # loop above might need to be increased. | |
285 | gdb_assert {$found_final_breakpoint} "ran all tests" | |
6b4c676c AB |
286 | } |
287 | ||
a5c641b5 AB |
288 | foreach_with_prefix repack { on off } { |
289 | run_test $repack | |
290 | } |