1 # Copyright
2021-2023 Free Software Foundation
, Inc.
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.
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.
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
/> .
16 # Testing GDB
's implementation of ASSOCIATED keyword.
18 require allow_fortran_tests
20 standard_testfile ".f90"
23 if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
28 if ![fortran_runto_main] {
32 gdb_breakpoint [gdb_get_line_number "Test Breakpoint"]
33 gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
35 # We place a limit on the number of tests that can be run, just in
36 # case something goes wrong, and GDB gets stuck in an loop here.
37 set found_final_breakpoint false
39 while { $test_count < 500 } {
40 with_test_prefix "test $test_count" {
43 gdb_test_multiple "continue" "continue" {
44 -re -wrap "! Test Breakpoint" {
45 # We can run a test from here.
47 -re -wrap "! Final Breakpoint" {
48 # We're done with the tests.
49 set found_final_breakpoint true
53 if ($found_final_breakpoint
) {
57 # First grab the expected answer.
58 set answer
[get_valueof
"" "answer" "**unknown**"]
60 # Now
move up a frame and figure out a command
for us to run
63 gdb_test_multiple
"up" "up" {
64 -re
-wrap
"\r\n\[0-9\]+\[ \t\]+call test_associated \\((\[^\r\n\]+)\\)" {
65 set command $expect_out
(1,string
)
69 gdb_assert
{ ![string equal $command
""] } "found a command to run"
71 gdb_test
"p $command" " = $answer"
75 # Ensure we reached the final breakpoint.
If more tests have been added
76 # to the test script
, and this starts failing
, then the safety
'while'
77 # loop above might need to be increased.
78 gdb_assert
{$found_final_breakpoint
} "ran all compiled in tests"
80 # Now perform the final tests. These should all be error condition
81 # checks
, for things that can
't be compiled into the test source file.
82 gdb_test "p associated (array_1d_p, an_integer)" \
83 "arguments to associated must be of same type and kind"
85 gdb_test "p associated (an_integer_p, a_real)" \
86 "arguments to associated must be of same type and kind"