blob: 2c92d606e56e2a3c3426ef42b9bd2b63bccd08d1 [file] [log] [blame]
# Copyright 2019-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
# 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 <> .
# Print a 2 dimensional assumed shape array. We pass different slices
# of the array to a subroutine and print the array as recieved within
# the subroutine. This should exercise GDB's ability to handle
# different strides for the different dimensions.
# Testing GDB's ability to print array (and string) slices, including
# slices that make use of array strides.
# In the Fortran code various arrays of different ranks are filled
# with data, and slices are passed to a series of show functions.
# In this test script we break in each of the show functions, print
# the array slice that was passed in, and then move up the stack to
# the parent frame and check GDB can manually extract the same slice.
# This test also checks that the size of the array slice passed to the
# function (so as extracted and described by the compiler and the
# debug information) matches the size of the slice manually extracted
# by GDB.
if {[skip_fortran_tests]} { return -1 }
standard_testfile ".f90"
load_lib fortran.exp
if {[build_executable ${testfile}.exp ${testfile} ${srcfile} \
{debug f90}]} {
return -1
# Takes the name of an array slice as used in the test source, and extracts
# the base array name. For example: 'array (1,2)' becomes 'array'.
proc array_slice_to_var { slice_str } {
regexp "^(?:\\s*\\()*(\[^( \t\]+)" $slice_str matchvar varname
return $varname
proc run_test { repack } {
global binfile gdb_prompt
clean_restart ${binfile}
# 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_test_no_output "set fortran repack-array-slices $repack"
# gdb_breakpoint [gdb_get_line_number "Display Message Breakpoint"]
gdb_breakpoint [gdb_get_line_number "Display Element"]
gdb_breakpoint [gdb_get_line_number "Display String"]
gdb_breakpoint [gdb_get_line_number "Display Array Slice 1D"]
gdb_breakpoint [gdb_get_line_number "Display Array Slice 2D"]
gdb_breakpoint [gdb_get_line_number "Display Array Slice 3D"]
gdb_breakpoint [gdb_get_line_number "Display Array Slice 4D"]
gdb_breakpoint [gdb_get_line_number "Final Breakpoint"]
# We're going to print some reasonably large arrays.
gdb_test_no_output "set print elements unlimited"
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 found_final_breakpoint false
set expected_result ""
set func_name ""
gdb_test_multiple "continue" "continue" {
-re ".*GDB = (\[^\r\n\]+)\r\n" {
set expected_result $expect_out(1,string)
-re "! Display Element" {
set func_name "show_elem"
-re "! Display String" {
set func_name "show_str"
-re "! Display Array Slice (.)D" {
set func_name "show_$expect_out(1,string)d"
-re "! Final Breakpoint" {
set found_final_breakpoint true
-re "$gdb_prompt $" {
# We're done.
if ($found_final_breakpoint) {
# 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_slice_name ""
set unique_id ""
array unset replacement_vars
array set replacement_vars {}
gdb_test_multiple "up" "up" {
-re "\r\n\[0-9\]+\[ \t\]+call ${func_name} \\((\[^\r\n\]+)\\)\r\n$gdb_prompt $" {
set array_slice_name $expect_out(1,string)
-re "\r\n\[0-9\]+\[ \t\]+call ${func_name} \\((\[^\r\n\]+)\\)\[ \t\]+! VARS=(\[^ \t\r\n\]+)\r\n$gdb_prompt $" {
set array_slice_name $expect_out(1,string)
set unique_id $expect_out(2,string)
if {$unique_id != ""} {
set str ""
foreach v [split $unique_id ,] {
set val [get_integer_valueof "${v}" "??"\
"get variable '$v' for '$array_slice_name'"]
set replacement_vars($v) $val
if {$str != ""} {
set str "Str,"
set str "$str$v=$val"
set unique_id " $str"
gdb_test_multiple "down" "down" {
-re "\r\n$gdb_prompt $" {
# Don't issue a pass here.
# Check we have all the information we need to successfully run one
# of these tests.
if { $expected_result == "" } {
perror "failed to extract expected results"
return 0
if { $array_slice_name == "" } {
perror "failed to extract array slice name"
return 0
# Check GDB can correctly print the array slice that was passed into
# the current frame.
set pattern [string_to_regexp " = $expected_result"]
gdb_test "p array" "$pattern" \
"check value of '$array_slice_name'$unique_id"
# Get the size of the slice.
set size_in_show \
[get_integer_valueof "sizeof (array)" "show_unknown" \
"get sizeof '$array_slice_name'$unique_id in show"]
set addr_in_show \
[get_hexadecimal_valueof "&array" "show_unknown" \
"get address '$array_slice_name'$unique_id in show"]
# Now move into the previous frame, and see if GDB can extract the
# array slice from the original parent object. Again, use of
# gdb_test_multiple to avoid filling the logs with unnecessary
# passes.
gdb_test_multiple "up" "up" {
-re "\r\n$gdb_prompt $" {
# Do nothing.
# Print the array slice, this will force GDB to manually extract the
# slice from the parent array.
gdb_test "p $array_slice_name" "$pattern" \
"check array slice '$array_slice_name'$unique_id can be extracted"
# Get the size of the slice in the calling frame.
set size_in_parent \
[get_integer_valueof "sizeof ($array_slice_name)" \
"parent_unknown" \
"get sizeof '$array_slice_name'$unique_id in parent"]
# Figure out the start and end addresses of the full array in the
# parent frame.
set full_var_name [array_slice_to_var $array_slice_name]
set start_addr [get_hexadecimal_valueof "&${full_var_name}" \
"start unknown"]
set end_addr [get_hexadecimal_valueof \
"$start_addr + sizeof (${full_var_name})" \
"end unknown" \
"get end address of ${full_var_name}"]
# The Fortran compiler can choose to either send a descriptor that
# describes the array slice to the subroutine, or it can repack the
# slice into an array section and send that.
# We find the address range of the original array in the parent,
# and the address of the slice in the show function, if the
# address of the slice (from show) is in the range of the original
# array then repacking has not occurred, otherwise, the slice is
# outside of the parent, and repacking must have occurred.
# The goal here is to compare the sizes of the slice in show with
# the size of the slice extracted by GDB. So we can only compare
# sizes when GDB's repacking setting matches the repacking
# behaviour we got from the compiler.
if { ($addr_in_show < $start_addr || $addr_in_show >= $end_addr) \
== ($repack == "on") } {
gdb_assert {$size_in_show == $size_in_parent} \
"check sizes match"
} elseif { $repack == "off" } {
# GDB's repacking is off (so slices are left unpacked), but
# the compiler did pack this one. As a result we can't
# compare the sizes between the compiler's slice and GDB's
# slice.
verbose -log "slice '$array_slice_name' was repacked, sizes can't be compared"
} else {
# Like the above, but the reverse, GDB's repacking is on, but
# the compiler didn't repack this slice.
verbose -log "slice '$array_slice_name' was not repacked, sizes can't be compared"
# If the array name we just tested included variable names, then
# test again with all the variables expanded.
if {$unique_id != ""} {
foreach v [array names replacement_vars] {
set val $replacement_vars($v)
set array_slice_name \
[regsub "\\y${v}\\y" $array_slice_name $val]
gdb_test "p $array_slice_name" "$pattern" \
"check array slice '$array_slice_name'$unique_id can be extracted, with variables expanded"
# 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} "ran all tests"
foreach_with_prefix repack { on off } {
run_test $repack