gdb/testsuite/gdb.fortran/lbound-ubound.exp

   1 # Copyright 2021-2023 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 # Testing GDB's implementation of LBOUND and UBOUND.
  17
  18 if {[skip_fortran_tests]} { return -1 }
  19
  20 standard_testfile ".F90"
  21 load_lib fortran.exp
  22
  23 if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
  24          {debug f90}]} {
  25     return -1
  26 }
  27
  28 # Avoid shared lib symbols.
  29 gdb_test_no_output "set auto-solib-add off"
  30
  31 if ![fortran_runto_main] {
  32     return -1
  33 }
  34
  35 # This test relies on output from the inferior.
  36 if [target_info exists gdb,noinferiorio] {
  37    return 0
  38 }
  39
  40 # Avoid libc symbols, in particular the 'array' type.
  41 gdb_test_no_output "nosharedlibrary"
  42
  43 gdb_breakpoint [gdb_get_line_number "Test Breakpoint"]
  44 gdb_breakpoint [gdb_get_line_number "Breakpoint before deallocate\."]
  45 gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
  46
  47 set found_dealloc_breakpoint false
  48
  49 # We place a limit on the number of tests that can be run, just in
  50 # case something goes wrong, and GDB gets stuck in an loop here.
  51 set test_count 0
  52 while { $test_count < 500 } {
  53     with_test_prefix "test $test_count" {
  54         incr test_count
  55
  56         set expected_lbound ""
  57         set expected_ubound ""
  58         set found_prompt false
  59         gdb_test_multiple "continue" "continue" {
  60             -i $::inferior_spawn_id
  61
  62             -re ".*LBOUND = (\[^\r\n\]+)\r\n" {
  63                 set expected_lbound $expect_out(1,string)
  64                 if {!$found_prompt} {
  65                     exp_continue
  66                 }
  67             }
  68             -re ".*UBOUND = (\[^\r\n\]+)\r\n" {
  69                 set expected_ubound $expect_out(1,string)
  70                 if {!$found_prompt} {
  71                     exp_continue
  72                 }
  73             }
  74
  75             -i $::gdb_spawn_id
  76
  77             -re "! Test Breakpoint" {
  78                 set func_name "show_elem"
  79                 exp_continue
  80             }
  81             -re "! Breakpoint before deallocate" {
  82                 set found_dealloc_breakpoint true
  83                 exp_continue
  84             }
  85             -re "$gdb_prompt $" {
  86                 set found_prompt true
  87
  88                 if {$found_dealloc_breakpoint
  89                     || ($expected_lbound != "" && $expected_ubound != "")} {
  90                     # We're done.
  91                 } else {
  92                     exp_continue
  93                 }
  94             }
  95         }
  96
  97         if ($found_dealloc_breakpoint) {
  98             break
  99         }
 100
 101         verbose -log "APB: Run a test here"
 102         verbose -log "APB: Expected lbound '$expected_lbound'"
 103         verbose -log "APB: Expected ubound '$expected_ubound'"
 104
 105         # We want to take a look at the line in the previous frame that
 106         # called the current function.  I couldn't find a better way of
 107         # doing this than 'up', which will print the line, then 'down'
 108         # again.
 109         #
 110         # I don't want to fill the log with passes for these up/down
 111         # commands, so we don't report any.  If something goes wrong then we
 112         # should get a fail from gdb_test_multiple.
 113         set array_name ""
 114         set xfail_data ""
 115         gdb_test_multiple "up" "up" {
 116             -re "\r\n\[0-9\]+\[ \t\]+DO_TEST \\((\[^\r\n\]+)\\)\r\n$gdb_prompt $" {
 117                 set array_name $expect_out(1,string)
 118             }
 119         }
 120
 121         # Check we have all the information we need to successfully run one
 122         # of these tests.
 123         if { $expected_lbound == "" } {
 124             perror "failed to extract expected results for lbound"
 125             return 0
 126         }
 127         if { $expected_ubound == "" } {
 128             perror "failed to extract expected results for ubound"
 129             return 0
 130         }
 131         if { $array_name == "" } {
 132             perror "failed to extract array name"
 133             return 0
 134         }
 135
 136         # Check GDB can correctly print complete set of upper and
 137         # lower bounds for an array.
 138         set pattern [string_to_regexp " = $expected_lbound"]
 139         gdb_test "p lbound ($array_name)" "$pattern" \
 140             "check value of lbound ('$array_name') expression"
 141         set pattern [string_to_regexp " = $expected_ubound"]
 142         gdb_test "p ubound ($array_name)" "$pattern" \
 143             "check value of ubound ('$array_name') expression"
 144
 145         # Now ask for each bound in turn and check it against the
 146         # expected results.
 147         #
 148         # First ask for bound 0.  This should fail, but will also tell
 149         # us the actual bounds of the array.  Thanks GDB.
 150         set upper_dim ""
 151         gdb_test_multiple "p lbound ($array_name, 0)" "" {
 152             -re "\r\nLBOUND dimension must be from 1 to (\[0-9\]+)\r\n$gdb_prompt $" {
 153                 set upper_dim $expect_out(1,string)
 154             }
 155         }
 156
 157         gdb_assert { ![string eq $upper_dim ""] } \
 158             "extracted the upper dimension value"
 159
 160         # Check that asking for the ubound dimension 0 gives the same
 161         # dimension range as in the lbound case.
 162         gdb_test_multiple "p ubound ($array_name, 0)" "" {
 163             -re "\r\nUBOUND dimension must be from 1 to (\[0-9\]+)\r\n$gdb_prompt $" {
 164                 gdb_assert {$upper_dim == $expect_out(1,string)} \
 165                     "ubound limit matches lbound limit"
 166             }
 167         }
 168
 169         # Now ask for the upper and lower bound for each dimension in
 170         # turn.  Add these results into a string which, when complete,
 171         # will look like the expected results seen above.
 172         set lbound_str ""
 173         set ubound_str ""
 174         set prefix "("
 175         for { set i 1 } { $i <= $upper_dim } { incr i } {
 176             set v [get_valueof "/d" "lbound ($array_name, $i)" "???"]
 177             set lbound_str "${lbound_str}${prefix}${v}"
 178
 179             set v [get_valueof "/d" "ubound ($array_name, $i)" "???"]
 180             set ubound_str "${ubound_str}${prefix}${v}"
 181
 182             set prefix ", "
 183         }
 184
 185         # Add closing parenthesis.
 186         set lbound_str "${lbound_str})"
 187         set ubound_str "${ubound_str})"
 188
 189         gdb_assert [string eq ${lbound_str} $expected_lbound] \
 190             "lbounds match"
 191         gdb_assert [string eq ${ubound_str} $expected_ubound] \
 192             "ubounds match"
 193
 194         # Finally, check that asking for a dimension above the valid
 195         # range gives the expected error.
 196         set bad_dim [expr $upper_dim + 1]
 197         gdb_test "p lbound ($array_name, $bad_dim)" \
 198             "LBOUND dimension must be from 1 to $upper_dim" \
 199             "check error message for lbound of dim = $bad_dim"
 200
 201         gdb_test "p ubound ($array_name, $bad_dim)" \
 202             "UBOUND dimension must be from 1 to $upper_dim" \
 203             "check error message for ubound of dim = $bad_dim"
 204
 205         # Move back up a frame just so we finish the test in frame 0.
 206         gdb_test_multiple "down" "down" {
 207             -re "\r\n$gdb_prompt $" {
 208                 # Don't issue a pass here.
 209             }
 210         }
 211     }
 212 }
 213
 214 gdb_assert {$found_dealloc_breakpoint} "ran all compiled in tests"
 215
 216 # Test the kind parameter of ubound and lbound a few times.
 217 gdb_test "p lbound(array_1d_1bytes_overflow, 1, 1)" "= 127"
 218 gdb_test "p lbound(array_1d_1bytes_overflow, 1, 2)" "= -129"
 219 gdb_test "p ubound(array_1d_1bytes_overflow, 1, 1)" "= -117"
 220
 221 gdb_test "p lbound(array_1d_2bytes_overflow, 1, 2)" "= 32757"
 222 gdb_test "p ubound(array_1d_2bytes_overflow, 1, 2)" "= -32766"
 223 gdb_test "p ubound(array_1d_2bytes_overflow, 1, 4)" "= 32770"
 224
 225 # On 32-bit machines most compilers will complain when trying to allocate an
 226 # array with ranges outside the 4 byte integer range.  As the behavior is
 227 # compiler implementation dependent, we do not run these test on 32 bit targets.
 228 if {[is_64_target]} {
 229     gdb_test "p lbound(array_1d_4bytes_overflow, 1, 4)" "= 2147483644"
 230     gdb_test "p lbound(array_1d_4bytes_overflow, 1, 8)" "= -2147483652"
 231     gdb_test "p ubound(array_1d_4bytes_overflow, 1, 4)" "= -2147483637"
 232     gdb_test "p lbound(array_1d_4bytes_overflow)" "= \\(2147483644\\)"
 233 }
 234
 235 # Ensure we reached the final breakpoint.  If more tests have been added
 236 # to the test script, and this starts failing, then the safety 'while'
 237 # loop above might need to be increased.
 238 gdb_continue_to_breakpoint "Final Breakpoint"
 239
 240 # Now for some final tests.  This is mostly testing that GDB gives the
 241 # correct errors in certain cases.
 242 foreach var {str_1 an_int} {
 243     foreach func {lbound ubound} {
 244         gdb_test "p ${func} ($var)" \
 245             "[string toupper $func] can only be applied to arrays"
 246     }
 247 }