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