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

# Make it easier to run the 'info modules' command (using
# GDBInfoModules), and the 'info module ...' commands (using
# GDBInfoModuleContents) and process the output.
#
# The difficulty we run into is that different versions of gFortran
# include different helper modules which show up in the results.  The
# procedures in this library help process those parts of the output we
# actually want to check, while ignoring those parts that we don't
# care about.
#
# For each namespace GDBInfoModules and GDBInfoModuleContents, there's
# a run_command proc, use this to run a command and capture the
# output.  Then make calls to check_header, check_entry, and
# check_no_entry to ensure the output was as expected.

namespace eval GDBInfoSymbols {

    # A string that is the header printed by GDB immediately after the
    # 'info [modules|types|functions|variables]' command has been issued.
    variable _header

    # A list of entries extracted from the output of the command.
    # Each entry is a filename, a line number, and the rest of the
    # text describing the entry.  If an entry has no line number then
    # it is replaced with the text NONE.
    variable _entries

    # The string that is the complete last command run.
    variable _last_command

    # Add a new entry to the _entries list.
    proc _add_entry { filename lineno text } {
	variable _entries

	set entry [list $filename $lineno $text]
	lappend _entries $entry
    }

    # Run the 'info modules' command, passing ARGS as extra arguments
    # to the command.  Process the output storing the results within
    # the variables in this namespace.
    #
    # The results of any previous call to run_command are discarded
    # when this is called.
    proc run_command { cmd { testname "" } } {
	global gdb_prompt

	variable _header
	variable _entries
	variable _last_command

	if {![regexp -- "^info (modules|types|variables|functions)" $cmd]} {
	    perror "invalid command"
	}

	set _header ""
	set _entries [list]
	set _last_command $cmd

	if { $testname == "" } {
	    set testname $cmd
	}

	send_gdb "$cmd\n"
	gdb_expect {
	    -re "^$cmd\r\n" {
		# Match the original command echoed back to us.
	    }
	    timeout {
		fail "$testname (timeout)"
		return 0
	    }
	}

	gdb_expect {
	    -re "^\r\n" {
		# Found the blank line after the header, we're done
		# parsing the header now.
	    }
	    -re "^\[ \t]*(\[^\r\n\]+)\r\n" {
		set str $expect_out(1,string)
		if { $_header == "" } {
		    set _header $str
		} else {
		    set _header "$_header $str"
		}
		exp_continue
	    }
	    timeout {
		fail "$testname (timeout)"
		return 0
	    }
	}

	set current_file ""
	gdb_expect {
	    -re "^File (\[^\r\n\]+):\r\n" {
		set current_file $expect_out(1,string)
		exp_continue
	    }
	    -re "^(\[0-9\]+):\[ \t\]+(\[^\r\n\]+)\r\n" {
		set lineno $expect_out(1,string)
		set text $expect_out(2,string)
		if { $current_file == "" } {
		    fail "$testname (missing filename)"
		    return 0
		}
		_add_entry $current_file $lineno $text
		exp_continue
	    }
	    -re "^\[ \t\]+(\[^\r\n\]+)\r\n" {
		set lineno "NONE"
		set text $expect_out(1,string)
		if { $current_file == "" } {
		    fail "$testname (missing filename)"
		    return 0
		}
		_add_entry $current_file $lineno $text
		exp_continue
	    }
	    -re "^\r\n" {
		exp_continue
	    }
	    -re "^$gdb_prompt $" {
		# All done.
	    }
	    timeout {
		fail "$testname (timeout)"
		return 0
	    }
	}

	pass $testname
	return 1
    }

    # Check that the header held in _header matches PATTERN.  Use
    # TESTNAME as the name of the test, or create a suitable default
    # test name based on the last command.
    proc check_header { pattern { testname "" } } {
	variable _header
	variable _last_command

	if { $testname == "" } {
	    set testname "$_last_command: check header"
	}

	gdb_assert {[regexp -- $pattern $_header]} $testname
    }

    # Call check_entry_1 with OPTIONAL == 0.
    proc check_entry { filename lineno text { testname "" } } {
	check_entry_1 $filename $lineno $text 0 $testname
    }

    # Call check_entry_1 with OPTIONAL == 1.
    proc check_optional_entry { filename lineno text { testname "" } } {
	check_entry_1 $filename $lineno $text 1 $testname
    }

    # Check that we have an entry in _entries matching FILENAME,
    # LINENO, and TEXT.  If LINENO is the empty string it is replaced
    # with the string NONE in order to match a similarly missing line
    # number in the output of the command.
    #
    # TESTNAME is the name of the test, or a default will be created
    # based on the last command run and the arguments passed here.
    #
    # If a matching entry is found then it is removed from the
    # _entries list, this allows us to check for duplicates using the
    # check_no_entry call.
    proc check_entry_1 { filename lineno text optional testname } {
	variable _entries
	variable _last_command

	if { $testname == "" } {
	    set testname \
		"$_last_command: check for entry '$filename', '$lineno', '$text'"
	}

	if { $lineno == "" } {
	    set lineno "NONE"
	}

	set new_entries [list]

	set found_match 0
	foreach entry $_entries {

	    if {!$found_match} {
		set f [lindex $entry 0]
		set l [lindex $entry 1]
		set t [lindex $entry 2]
		if { [regexp -- $filename $f] \
			 && [regexp -- $lineno $l] \
			 && [regexp -- $text $t] } {
		    set found_match 1
		} else {
		    lappend new_entries $entry
		}
	    } else {
		lappend new_entries $entry
	    }
	}

	set _entries $new_entries
	if { $optional && ! $found_match } {
	    unsupported $testname
	} else {
	    gdb_assert { $found_match } $testname
	}
    }

    # Check that there is no entry in the _entries list matching
    # FILENAME, LINENO, and TEXT.  The LINENO and TEXT are optional,
    # and will be replaced with '.*' if missing.
    #
    # If LINENO is the empty string then it will be replaced with the
    # string NONE in order to match against missing line numbers in
    # the output of the command.
    #
    # TESTNAME is the name of the test, or a default will be built
    # from the last command run and the arguments passed here.
    #
    # This can be used after a call to check_entry to ensure that
    # there are no further matches for a particular file in the
    # output.
    proc check_no_entry { filename { lineno ".*" } { text ".*" } \
			      { testname "" } } {
	variable _entries
	variable _last_command

	if { $testname == "" } {
	    set testname \
		"$_last_command: check no matches for '$filename', '$lineno', and '$text'"
	}

	if { $lineno == "" } {
	    set lineno "NONE"
	}

	foreach entry $_entries {
	    set f [lindex $entry 0]
	    set l [lindex $entry 1]
	    set t [lindex $entry 2]
	    if { [regexp -- $filename $f] \
		     && [regexp -- $lineno $l] \
		     && [regexp -- $text $t] } {
		fail $testname
	    }
	}

	pass $testname
    }
}


namespace eval GDBInfoModuleSymbols {

    # A string that is the header printed by GDB immediately after the
    # 'info modules (variables|functions)' command has been issued.
    variable _header

    # A list of entries extracted from the output of the command.
    # Each entry is a filename, a module name, a line number, and the
    # rest of the text describing the entry.  If an entry has no line
    # number then it is replaced with the text NONE.
    variable _entries

    # The string that is the complete last command run.
    variable _last_command

    # Add a new entry to the _entries list.
    proc _add_entry { filename module lineno text } {
	variable _entries

	set entry [list $filename $module $lineno $text]
	lappend _entries $entry
    }

    # Run the 'info module ....' command, passing ARGS as extra
    # arguments to the command.  Process the output storing the
    # results within the variables in this namespace.
    #
    # The results of any previous call to run_command are discarded
    # when this is called.
    proc run_command { cmd { testname "" } } {
	global gdb_prompt

	variable _header
	variable _entries
	variable _last_command

	if {![regexp -- "^info module (variables|functions)" $cmd]} {
	    perror "invalid command: '$cmd'"
	}

	set _header ""
	set _entries [list]
	set _last_command $cmd

	if { $testname == "" } {
	    set testname $cmd
	}

	send_gdb "$cmd\n"
	gdb_expect {
	    -re "^$cmd\r\n" {
		# Match the original command echoed back to us.
	    }
	    timeout {
		fail "$testname (timeout)"
		return 0
	    }
	}

	gdb_expect {
	    -re "^\r\n" {
		# Found the blank line after the header, we're done
		# parsing the header now.
	    }
	    -re "^\[ \t\]*(\[^\r\n\]+)\r\n" {
		set str $expect_out(1,string)
		if { $_header == "" } {
		    set _header $str
		} else {
		    set _header "$_header $str"
		}
		exp_continue
	    }
	    timeout {
		fail "$testname (timeout)"
		return 0
	    }
	}

	set current_module ""
	set current_file ""
	gdb_expect {
	    -re "^Module \"(\[^\"\]+)\":\r\n" {
		set current_module $expect_out(1,string)
		exp_continue
	    }
	    -re "^File (\[^\r\n\]+):\r\n" {
		if { $current_module == "" } {
		    fail "$testname (missing module)"
		    return 0
		}
		set current_file $expect_out(1,string)
		exp_continue
	    }
	    -re "^(\[0-9\]+):\[ \t\]+(\[^\r\n\]+)\r\n" {
		set lineno $expect_out(1,string)
		set text $expect_out(2,string)
		if { $current_module == "" } {
		    fail "$testname (missing module)"
		    return 0
		}
		if { $current_file == "" } {
		    fail "$testname (missing filename)"
		    return 0
		}
		_add_entry $current_file $current_module \
		    $lineno $text
		exp_continue
	    }
	    -re "^\[ \t\]+(\[^\r\n\]+)\r\n" {
		set lineno "NONE"
		set text $expect_out(1,string)
		if { $current_module == "" } {
		    fail "$testname (missing module)"
		    return 0
		}
		if { $current_file == "" } {
		    fail "$testname (missing filename)"
		    return 0
		}
		_add_entry $current_file $current_module \
		    $lineno $text
		exp_continue
	    }
	    -re "^\r\n" {
		exp_continue
	    }
	    -re "^$gdb_prompt $" {
		# All done.
	    }
	    timeout {
		fail "$testname (timeout)"
		return 0
	    }
	}

	pass $testname
	return 1
    }

    # Check that the header held in _header matches PATTERN.  Use
    # TESTNAME as the name of the test, or create a suitable default
    # test name based on the last command.
    proc check_header { pattern { testname "" } } {
	variable _header
	variable _last_command

	if { $testname == "" } {
	    set testname "$_last_command: check header"
	}

	gdb_assert {[regexp -- $pattern $_header]} $testname
    }

    # Check that we have an entry in _entries matching FILENAME,
    # MODULE, LINENO, and TEXT.  If LINENO is the empty string it is
    # replaced with the string NONE in order to match a similarly
    # missing line number in the output of the command.
    #
    # TESTNAME is the name of the test, or a default will be created
    # based on the last command run and the arguments passed here.
    #
    # If a matching entry is found then it is removed from the
    # _entries list, this allows us to check for duplicates using the
    # check_no_entry call.
    #
    # If OPTIONAL, don't generate a FAIL for a mismatch, but use UNSUPPORTED
    # instead.
    proc check_entry_1 { filename module lineno text optional testname } {
	variable _entries
	variable _last_command

	if { $testname == "" } {
	    set testname \
		"$_last_command: check for entry '$filename', '$lineno', '$text'"
	}

	if { $lineno == "" } {
	    set lineno "NONE"
	}

	set new_entries [list]

	set found_match 0
	foreach entry $_entries {

	    if {!$found_match} {
		set f [lindex $entry 0]
		set m [lindex $entry 1]
		set l [lindex $entry 2]
		set t [lindex $entry 3]
		if { [regexp -- $filename $f] \
			 && [regexp -- $module $m] \
			 && [regexp -- $lineno $l] \
			 && [regexp -- $text $t] } {
		    set found_match 1
		} else {
		    lappend new_entries $entry
		}
	    } else {
		lappend new_entries $entry
	    }
	}

	set _entries $new_entries
	if { $optional && ! $found_match } {
	    unsupported $testname
	} else {
	    gdb_assert { $found_match } $testname
	}
    }

    # Call check_entry_1 with OPTIONAL == 0.
    proc check_entry { filename module lineno text { testname "" } } {
	check_entry_1 $filename $module $lineno $text 0 $testname
    }

    # Call check_entry_1 with OPTIONAL == 1.
    proc check_optional_entry { filename module lineno text { testname "" } } {
	check_entry_1 $filename $module $lineno $text 1 $testname
    }

    # Check that there is no entry in the _entries list matching
    # FILENAME, MODULE, LINENO, and TEXT.  The LINENO and TEXT are
    # optional, and will be replaced with '.*' if missing.
    #
    # If LINENO is the empty string then it will be replaced with the
    # string NONE in order to match against missing line numbers in
    # the output of the command.
    #
    # TESTNAME is the name of the test, or a default will be built
    # from the last command run and the arguments passed here.
    #
    # This can be used after a call to check_entry to ensure that
    # there are no further matches for a particular file in the
    # output.
    proc check_no_entry { filename module { lineno ".*" } \
			      { text ".*" } { testname "" } } {
	variable _entries
	variable _last_command

	if { $testname == "" } {
	    set testname \
		"$_last_command: check no matches for '$filename', '$lineno', and '$text'"
	}

	if { $lineno == "" } {
	    set lineno "NONE"
	}

	foreach entry $_entries {
	    set f [lindex $entry 0]
	    set m [lindex $entry 1]
	    set l [lindex $entry 2]
	    set t [lindex $entry 3]
	    if { [regexp -- $filename $f] \
		     && [regexp -- $module $m] \
		     && [regexp -- $lineno $l] \
		     && [regexp -- $text $t] } {
		fail $testname
	    }
	}

	pass $testname
    }
}