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

   1 # Copyright 2019-2021 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 recieved 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 if {[skip_fortran_tests]} { return -1 }
  37
  38 standard_testfile ".f90"
  39 load_lib fortran.exp
  40
  41 if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
  42          {debug f90}]} {
  43     return -1
  44 }
  45
  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
  51 }
  52
  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
  61     }
  62
  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             }
 114
 115             if ($found_final_breakpoint) {
 116                 break
 117             }
 118
 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 \
 211                               "(&${full_var_name}) + sizeof (${full_var_name})" \
 212                               "end unknown"]
 213
 214             # The Fortran compiler can choose to either send a descriptor that
 215             # describes the array slice to the subroutine, or it can repack the
 216             # slice into an array section and send that.
 217             #
 218             # We find the address range of the original array in the parent,
 219             # and the address of the slice in the show function, if the
 220             # address of the slice (from show) is in the range of the original
 221             # array then repacking has not occurred, otherwise, the slice is
 222             # outside of the parent, and repacking must have occurred.
 223             #
 224             # The goal here is to compare the sizes of the slice in show with
 225             # the size of the slice extracted by GDB.  So we can only compare
 226             # sizes when GDB's repacking setting matches the repacking
 227             # behaviour we got from the compiler.
 228             if { ($addr_in_show < $start_addr || $addr_in_show >= $end_addr) \
 229                  == ($repack == "on") } {
 230                 gdb_assert {$size_in_show == $size_in_parent} \
 231                     "check sizes match"
 232             } elseif { $repack == "off" } {
 233                 # GDB's repacking is off (so slices are left unpacked), but
 234                 # the compiler did pack this one.  As a result we can't
 235                 # compare the sizes between the compiler's slice and GDB's
 236                 # slice.
 237                 verbose -log "slice '$array_slice_name' was repacked, sizes can't be compared"
 238             } else {
 239                 # Like the above, but the reverse, GDB's repacking is on, but
 240                 # the compiler didn't repack this slice.
 241                 verbose -log "slice '$array_slice_name' was not repacked, sizes can't be compared"
 242             }
 243
 244             # If the array name we just tested included variable names, then
 245             # test again with all the variables expanded.
 246             if {$unique_id != ""} {
 247                 foreach v [array names replacement_vars] {
 248                     set val $replacement_vars($v)
 249                     set array_slice_name \
 250                         [regsub "\\y${v}\\y" $array_slice_name $val]
 251                 }
 252                 gdb_test "p $array_slice_name" "$pattern" \
 253                     "check array slice '$array_slice_name'$unique_id can be extracted, with variables expanded"
 254             }
 255         }
 256     }
 257
 258     # Ensure we reached the final breakpoint.  If more tests have been added
 259     # to the test script, and this starts failing, then the safety 'while'
 260     # loop above might need to be increased.
 261     gdb_assert {$found_final_breakpoint} "ran all tests"
 262 }
 263
 264 foreach_with_prefix repack { on off } {
 265     run_test $repack
 266 }