1 # Copyright 2019-2024 Free Software Foundation, Inc. 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 received within 18 # the subroutine. This should exercise GDB's ability to handle 19 # different strides for the different dimensions. 20 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 36 require allow_fortran_tests 37 38 # This test relies on output from the inferior. 39 require {!target_info exists gdb,noinferiorio} 40 41 standard_testfile ".f90" 42 load_lib fortran.exp 43 44 if {[build_executable ${testfile}.exp ${testfile} ${srcfile} \ 45 {debug f90}]} { 46 return -1 47 } 48 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 54 } 55 56 proc run_test { repack } { 57 global binfile gdb_prompt 58 59 clean_restart ${binfile} 60 61 # Avoid shared lib symbols. 62 gdb_test_no_output "set auto-solib-add off" 63 64 if ![fortran_runto_main] { 65 return -1 66 } 67 68 # Avoid libc symbols, in particular the 'array' type. 69 gdb_test_no_output "nosharedlibrary" 70 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 "" 97 set found_prompt false 98 gdb_test_multiple "continue" "continue" { 99 -i $::inferior_spawn_id 100 101 -re ".*GDB = (\[^\r\n\]+)\r\n" { 102 set expected_result $expect_out(1,string) 103 if {!$found_prompt} { 104 exp_continue 105 } 106 } 107 108 -i $::gdb_spawn_id 109 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 $" { 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 } 135 } 136 } 137 138 if ($found_final_breakpoint) { 139 break 140 } 141 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 \ 234 "$start_addr + sizeof (${full_var_name})" \ 235 "end unknown" \ 236 "get end address of ${full_var_name}"] 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" 286 } 287 288 foreach_with_prefix repack { on off } { 289 run_test $repack 290 } 291
Indexes created Mon Mar 02 05:31:46 UTC 2026