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 SHAPE 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_shape \\((\[^\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	set answer [string_to_regexp $answer]
72	gdb_test "p $command" " = $answer"
73    }
74}
75
76# Ensure we reached the final breakpoint.  If more tests have been added
77# to the test script, and this starts failing, then the safety 'while'
78# loop above might need to be increased.
79gdb_assert {$found_final_breakpoint} "ran all compiled in tests"
80
81foreach var {array_1d_p array_2d_p allocatable_array_1d \
82		 allocatable_array_2d} {
83    gdb_test "p shape ($var)" \
84	"The array passed to SHAPE must be allocated or associated"
85}
86