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

   1 # Copyright 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 # 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
  29 if ![fortran_runto_main] {
  30     untested "could not run to main"
  31     return -1
  32 }
  33
  34 gdb_breakpoint [gdb_get_line_number "Test Breakpoint"]
  35 gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
  36
  37 set found_final_breakpoint false
  38
  39 # We place a limit on the number of tests that can be run, just in
  40 # case something goes wrong, and GDB gets stuck in an loop here.
  41 set test_count 0
  42 while { $test_count < 500 } {
  43     with_test_prefix "test $test_count" {
  44         incr test_count
  45
  46         set expected_lbound ""
  47         set expected_ubound ""
  48         gdb_test_multiple "continue" "continue" {
  49             -re ".*LBOUND = (\[^\r\n\]+)\r\n" {
  50                 set expected_lbound $expect_out(1,string)
  51                 exp_continue
  52             }
  53             -re ".*UBOUND = (\[^\r\n\]+)\r\n" {
  54                 set expected_ubound $expect_out(1,string)
  55                 exp_continue
  56             }
  57             -re "! Test Breakpoint" {
  58                 set func_name "show_elem"
  59                 exp_continue
  60             }
  61             -re "! Final Breakpoint" {
  62                 set found_final_breakpoint true
  63                 exp_continue
  64             }
  65             -re "$gdb_prompt $" {
  66                 # We're done.
  67             }
  68         }
  69
  70         if ($found_final_breakpoint) {
  71             break
  72         }
  73
  74         verbose -log "APB: Run a test here"
  75         verbose -log "APB: Expected lbound '$expected_lbound'"
  76         verbose -log "APB: Expected ubound '$expected_ubound'"
  77
  78         # We want to take a look at the line in the previous frame that
  79         # called the current function.  I couldn't find a better way of
  80         # doing this than 'up', which will print the line, then 'down'
  81         # again.
  82         #
  83         # I don't want to fill the log with passes for these up/down
  84         # commands, so we don't report any.  If something goes wrong then we
  85         # should get a fail from gdb_test_multiple.
  86         set array_name ""
  87         set xfail_data ""
  88         gdb_test_multiple "up" "up" {
  89             -re "\r\n\[0-9\]+\[ \t\]+DO_TEST \\((\[^\r\n\]+)\\)\r\n$gdb_prompt $" {
  90                 set array_name $expect_out(1,string)
  91             }
  92         }
  93
  94         # Check we have all the information we need to successfully run one
  95         # of these tests.
  96         if { $expected_lbound == "" } {
  97             perror "failed to extract expected results for lbound"
  98             return 0
  99         }
 100         if { $expected_ubound == "" } {
 101             perror "failed to extract expected results for ubound"
 102             return 0
 103         }
 104         if { $array_name == "" } {
 105             perror "failed to extract array name"
 106             return 0
 107         }
 108
 109         # Check GDB can correctly print complete set of upper and
 110         # lower bounds for an array.
 111         set pattern [string_to_regexp " = $expected_lbound"]
 112         gdb_test "p lbound ($array_name)" "$pattern" \
 113             "check value of lbound ('$array_name') expression"
 114         set pattern [string_to_regexp " = $expected_ubound"]
 115         gdb_test "p ubound ($array_name)" "$pattern" \
 116             "check value of ubound ('$array_name') expression"
 117
 118         # Now ask for each bound in turn and check it against the
 119         # expected results.
 120         #
 121         # First ask for bound 0.  This should fail, but will also tell
 122         # us the actual bounds of the array.  Thanks GDB.
 123         set upper_dim ""
 124         gdb_test_multiple "p lbound ($array_name, 0)" "" {
 125             -re "\r\nLBOUND dimension must be from 1 to (\[0-9\]+)\r\n$gdb_prompt $" {
 126                 set upper_dim $expect_out(1,string)
 127             }
 128         }
 129
 130         gdb_assert { ![string eq $upper_dim ""] } \
 131             "extracted the upper dimension value"
 132
 133         # Check that asking for the ubound dimension 0 gives the same
 134         # dimension range as in the lbound case.
 135         gdb_test_multiple "p ubound ($array_name, 0)" "" {
 136             -re "\r\nUBOUND dimension must be from 1 to (\[0-9\]+)\r\n$gdb_prompt $" {
 137                 gdb_assert {$upper_dim == $expect_out(1,string)} \
 138                     "ubound limit matches lbound limit"
 139             }
 140         }
 141
 142         # Now ask for the upper and lower bound for each dimension in
 143         # turn.  Add these results into a string which, when complete,
 144         # will look like the expected results seen above.
 145         set lbound_str ""
 146         set ubound_str ""
 147         set prefix "("
 148         for { set i 1 } { $i <= $upper_dim } { incr i } {
 149             set v [get_valueof "/d" "lbound ($array_name, $i)" "???"]
 150             set lbound_str "${lbound_str}${prefix}${v}"
 151
 152             set v [get_valueof "/d" "ubound ($array_name, $i)" "???"]
 153             set ubound_str "${ubound_str}${prefix}${v}"
 154
 155             set prefix ", "
 156         }
 157
 158         # Add closing parenthesis.
 159         set lbound_str "${lbound_str})"
 160         set ubound_str "${ubound_str})"
 161
 162         gdb_assert [string eq ${lbound_str} $expected_lbound] \
 163             "lbounds match"
 164         gdb_assert [string eq ${ubound_str} $expected_ubound] \
 165             "ubounds match"
 166
 167         # Finally, check that asking for a dimension above the valid
 168         # range gives the expected error.
 169         set bad_dim [expr $upper_dim + 1]
 170         gdb_test "p lbound ($array_name, $bad_dim)" \
 171             "LBOUND dimension must be from 1 to $upper_dim" \
 172             "check error message for lbound of dim = $bad_dim"
 173
 174         gdb_test "p ubound ($array_name, $bad_dim)" \
 175             "UBOUND dimension must be from 1 to $upper_dim" \
 176             "check error message for ubound of dim = $bad_dim"
 177
 178         # Move back up a frame just so we finish the test in frame 0.
 179         gdb_test_multiple "down" "down" {
 180             -re "\r\n$gdb_prompt $" {
 181                 # Don't issue a pass here.
 182             }
 183         }
 184     }
 185 }
 186
 187 # Ensure we reached the final breakpoint.  If more tests have been added
 188 # to the test script, and this starts failing, then the safety 'while'
 189 # loop above might need to be increased.
 190 gdb_assert {$found_final_breakpoint} "reached final breakpoint"
 191
 192 # Now for some final tests.  This is mostly testing that GDB gives the
 193 # correct errors in certain cases.
 194 foreach var {str_1 an_int} {
 195     foreach func {lbound ubound} {
 196         gdb_test "p ${func} ($var)" \
 197             "[string toupper $func] can only be applied to arrays"
 198     }
 199 }