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 ASSOCIATED keyword.
17
18if {[skip_fortran_tests]} { return -1 }
19
20standard_testfile ".f90"
21load_lib fortran.exp
22
23if {[prepare_for_testing ${testfile}.exp ${testfile} ${srcfile} \
24	 {debug f90}]} {
25    return -1
26}
27
28if ![fortran_runto_main] {
29    return -1
30}
31
32gdb_breakpoint [gdb_get_line_number "Test Breakpoint"]
33gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
34
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.
37set found_final_breakpoint false
38set test_count 0
39while { $test_count < 500 } {
40    with_test_prefix "test $test_count" {
41	incr test_count
42
43	gdb_test_multiple "continue" "continue" {
44	    -re -wrap "! Test Breakpoint" {
45		# We can run a test from here.
46	    }
47	    -re -wrap "! Final Breakpoint" {
48		# We're done with the tests.
49		set found_final_breakpoint true
50	    }
51	}
52
53	if ($found_final_breakpoint) {
54	    break
55	}
56
57	# First grab the expected answer.
58	set answer [get_valueof "" "answer" "**unknown**"]
59
60	# Now move up a frame and figure out a command for us to run
61	# as a test.
62	set command ""
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)
66	    }
67	}
68
69	gdb_assert { ![string equal $command ""] } "found a command to run"
70
71	gdb_test "p $command" " = $answer"
72    }
73}
74
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.
78gdb_assert {$found_final_breakpoint} "ran all compiled in tests"
79
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.
82gdb_test "p associated (array_1d_p, an_integer)" \
83    "arguments to associated must be of same type and kind"
84
85gdb_test "p associated (an_integer_p, a_real)" \
86    "arguments to associated must be of same type and kind"
87