gdb/testsuite/gdb.fortran/array-slices.exp

   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 }