| # Copyright 2021 Free Software Foundation, Inc. |
| |
| # This program is free software; you can redistribute it and/or modify |
| # it under the terms of the GNU General Public License as published by |
| # the Free Software Foundation; either version 3 of the License, or |
| # (at your option) any later version. |
| # |
| # This program is distributed in the hope that it will be useful, |
| # but WITHOUT ANY WARRANTY; without even the implied warranty of |
| # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
| # GNU General Public License for more details. |
| # |
| # You should have received a copy of the GNU General Public License |
| # along with this program. If not, see <http://www.gnu.org/licenses/> . |
| |
| # Testing GDB's implementation of LBOUND and UBOUND. |
| |
| if {[skip_fortran_tests]} { return -1 } |
| |
| standard_testfile ".F90" |
| load_lib fortran.exp |
| |
| if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \ |
| {debug f90}]} { |
| return -1 |
| } |
| |
| # Avoid shared lib symbols. |
| gdb_test_no_output "set auto-solib-add off" |
| |
| if ![fortran_runto_main] { |
| return -1 |
| } |
| |
| # Avoid libc symbols, in particular the 'array' type. |
| gdb_test_no_output "nosharedlibrary" |
| |
| gdb_breakpoint [gdb_get_line_number "Test Breakpoint"] |
| gdb_breakpoint [gdb_get_line_number "Final Breakpoint"] |
| |
| set found_final_breakpoint false |
| |
| # We place a limit on the number of tests that can be run, just in |
| # case something goes wrong, and GDB gets stuck in an loop here. |
| set test_count 0 |
| while { $test_count < 500 } { |
| with_test_prefix "test $test_count" { |
| incr test_count |
| |
| set expected_lbound "" |
| set expected_ubound "" |
| gdb_test_multiple "continue" "continue" { |
| -re ".*LBOUND = (\[^\r\n\]+)\r\n" { |
| set expected_lbound $expect_out(1,string) |
| exp_continue |
| } |
| -re ".*UBOUND = (\[^\r\n\]+)\r\n" { |
| set expected_ubound $expect_out(1,string) |
| exp_continue |
| } |
| -re "! Test Breakpoint" { |
| set func_name "show_elem" |
| exp_continue |
| } |
| -re "! Final Breakpoint" { |
| set found_final_breakpoint true |
| exp_continue |
| } |
| -re "$gdb_prompt $" { |
| # We're done. |
| } |
| } |
| |
| if ($found_final_breakpoint) { |
| break |
| } |
| |
| verbose -log "APB: Run a test here" |
| verbose -log "APB: Expected lbound '$expected_lbound'" |
| verbose -log "APB: Expected ubound '$expected_ubound'" |
| |
| # We want to take a look at the line in the previous frame that |
| # called the current function. I couldn't find a better way of |
| # doing this than 'up', which will print the line, then 'down' |
| # again. |
| # |
| # I don't want to fill the log with passes for these up/down |
| # commands, so we don't report any. If something goes wrong then we |
| # should get a fail from gdb_test_multiple. |
| set array_name "" |
| set xfail_data "" |
| gdb_test_multiple "up" "up" { |
| -re "\r\n\[0-9\]+\[ \t\]+DO_TEST \\((\[^\r\n\]+)\\)\r\n$gdb_prompt $" { |
| set array_name $expect_out(1,string) |
| } |
| } |
| |
| # Check we have all the information we need to successfully run one |
| # of these tests. |
| if { $expected_lbound == "" } { |
| perror "failed to extract expected results for lbound" |
| return 0 |
| } |
| if { $expected_ubound == "" } { |
| perror "failed to extract expected results for ubound" |
| return 0 |
| } |
| if { $array_name == "" } { |
| perror "failed to extract array name" |
| return 0 |
| } |
| |
| # Check GDB can correctly print complete set of upper and |
| # lower bounds for an array. |
| set pattern [string_to_regexp " = $expected_lbound"] |
| gdb_test "p lbound ($array_name)" "$pattern" \ |
| "check value of lbound ('$array_name') expression" |
| set pattern [string_to_regexp " = $expected_ubound"] |
| gdb_test "p ubound ($array_name)" "$pattern" \ |
| "check value of ubound ('$array_name') expression" |
| |
| # Now ask for each bound in turn and check it against the |
| # expected results. |
| # |
| # First ask for bound 0. This should fail, but will also tell |
| # us the actual bounds of the array. Thanks GDB. |
| set upper_dim "" |
| gdb_test_multiple "p lbound ($array_name, 0)" "" { |
| -re "\r\nLBOUND dimension must be from 1 to (\[0-9\]+)\r\n$gdb_prompt $" { |
| set upper_dim $expect_out(1,string) |
| } |
| } |
| |
| gdb_assert { ![string eq $upper_dim ""] } \ |
| "extracted the upper dimension value" |
| |
| # Check that asking for the ubound dimension 0 gives the same |
| # dimension range as in the lbound case. |
| gdb_test_multiple "p ubound ($array_name, 0)" "" { |
| -re "\r\nUBOUND dimension must be from 1 to (\[0-9\]+)\r\n$gdb_prompt $" { |
| gdb_assert {$upper_dim == $expect_out(1,string)} \ |
| "ubound limit matches lbound limit" |
| } |
| } |
| |
| # Now ask for the upper and lower bound for each dimension in |
| # turn. Add these results into a string which, when complete, |
| # will look like the expected results seen above. |
| set lbound_str "" |
| set ubound_str "" |
| set prefix "(" |
| for { set i 1 } { $i <= $upper_dim } { incr i } { |
| set v [get_valueof "/d" "lbound ($array_name, $i)" "???"] |
| set lbound_str "${lbound_str}${prefix}${v}" |
| |
| set v [get_valueof "/d" "ubound ($array_name, $i)" "???"] |
| set ubound_str "${ubound_str}${prefix}${v}" |
| |
| set prefix ", " |
| } |
| |
| # Add closing parenthesis. |
| set lbound_str "${lbound_str})" |
| set ubound_str "${ubound_str})" |
| |
| gdb_assert [string eq ${lbound_str} $expected_lbound] \ |
| "lbounds match" |
| gdb_assert [string eq ${ubound_str} $expected_ubound] \ |
| "ubounds match" |
| |
| # Finally, check that asking for a dimension above the valid |
| # range gives the expected error. |
| set bad_dim [expr $upper_dim + 1] |
| gdb_test "p lbound ($array_name, $bad_dim)" \ |
| "LBOUND dimension must be from 1 to $upper_dim" \ |
| "check error message for lbound of dim = $bad_dim" |
| |
| gdb_test "p ubound ($array_name, $bad_dim)" \ |
| "UBOUND dimension must be from 1 to $upper_dim" \ |
| "check error message for ubound of dim = $bad_dim" |
| |
| # Move back up a frame just so we finish the test in frame 0. |
| gdb_test_multiple "down" "down" { |
| -re "\r\n$gdb_prompt $" { |
| # Don't issue a pass here. |
| } |
| } |
| } |
| } |
| |
| # Ensure we reached the final breakpoint. If more tests have been added |
| # to the test script, and this starts failing, then the safety 'while' |
| # loop above might need to be increased. |
| gdb_assert {$found_final_breakpoint} "reached final breakpoint" |
| |
| # Now for some final tests. This is mostly testing that GDB gives the |
| # correct errors in certain cases. |
| foreach var {str_1 an_int} { |
| foreach func {lbound ubound} { |
| gdb_test "p ${func} ($var)" \ |
| "[string toupper $func] can only be applied to arrays" |
| } |
| } |