Update copyright year range in header of all files managed by GDB

[thirdparty/binutils-gdb.git] / gdb / testsuite / gdb.fortran / array-slices.exp

# Copyright 2019-2023 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/> .

# 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 }

# This test relies on output from the inferior.
if [target_info exists gdb,noinferiorio] {
    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 ""
	    set found_prompt false
	    gdb_test_multiple "continue" "continue" {
		-i $::inferior_spawn_id

		-re ".*GDB = (\[^\r\n\]+)\r\n" {
		    set expected_result $expect_out(1,string)
		    if {!$found_prompt} {
			exp_continue
		    }
		}

		-i $::gdb_spawn_id

		-re "! Display Element" {
		    set func_name "show_elem"
		    exp_continue
		}
		-re "! Display String" {
		    set func_name "show_str"
		    exp_continue
		}
		-re "! Display Array Slice (.)D" {
		    set func_name "show_$expect_out(1,string)d"
		    exp_continue
		}
		-re "! Final Breakpoint" {
		    set found_final_breakpoint true
		    exp_continue
		}
		-re "$gdb_prompt $" {
		    set found_prompt true

		    if {$found_final_breakpoint
			|| ($expected_result != "" && $func_name != "")} {
			# We're done.
		    } else {
			exp_continue
		    }
		}
	    }

	    if ($found_final_breakpoint) {
		break
	    }

	    # 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
}