gdb/testsuite/lib/ada.exp - binutils-gdb - Git at Google

 # Copyright 2004-2025 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/>.

 # A wrapper for foreach_with_prefix that applies suitable
 # -fgnat-encodings arguments to a command line.  SCENARIO_ARG is the
 # name of a loop variable that will hold the scenario currently being
 # evaluated.  FLAGS_ARG will be set to the appropriate compiler flags
 # (if any) for this scenario.  LIST is the list of desired scenarios
 # to run, and BODY is what actually does the work.

 proc foreach_gnat_encoding {scenario_arg flags_arg list body} {
     # gnat-llvm does not understand -fgnat-encodings at all.  However,
     # some tests examine the precise setting of the scenario -- so
     # pretend we support minimal.  What is going on here is that for
     # gnat-llvm, there are no "GNAT encodings", only minimal
     # encodings, aka, real DWARF.
     set has_flag [ada_minimal_encodings]
     if {!$has_flag} {
 	set list minimal
     }

     upvar 1 $scenario_arg scenario
     upvar 1 $flags_arg flags
     foreach_with_prefix scenario $list {
 	set flags {}
 	if {$scenario != "none" && $has_flag} {
 	    lappend flags additional_flags=-fgnat-encodings=$scenario
 	}
 	uplevel 1 $body
     }
 }

 # Call target_compile with SOURCE DEST TYPE and OPTIONS as argument,
 # after having temporarily changed the current working directory to
 # BUILDDIR.

 proc target_compile_ada_from_dir {builddir source dest type options} {
     global board
     set board [target_info name]
     set save_multilib_flag [board_info $board multilib_flags]
     set multilib_flag ""
     foreach op $save_multilib_flag {
 	if { $op == "-pie" || $op == "-no-pie" } {
 	    # Pretend gnatmake supports -pie/-no-pie, route it to
 	    # linker.
 	    append multilib_flag " -largs $op -margs"
 	} else {
 	    append multilib_flag " $op"
 	}
     }
     if { $multilib_flag != "" } {
 	unset_board_info "multilib_flags"
 	set_board_info multilib_flags "$multilib_flag"
     }

     catch {
 	with_cwd $builddir {
 	    return [target_compile $source $dest $type $options]
 	}
     } result options

     if { $save_multilib_flag != "" } {
 	unset_board_info "multilib_flags"
 	set_board_info multilib_flags $save_multilib_flag
     }

     return -options $options $result
 }

 # Compile some Ada code.  Return "" if the compile was successful.
 # OPTIONS are as for target_compile, but with this addition:
 # "no-force" - do not pass -f to gnatmake.  By default -f is
 # used, forcing a full recompilation.

 proc gdb_compile_ada_1 {source dest type options} {

     set srcdir [file dirname $source]
     set gprdir [file dirname $srcdir]
     set objdir [file dirname $dest]

     file delete $dest

     # Although strictly not necessary, we force the recompilation
     # of all units (additional_flags=-f).  This is what is done
     # when using GCC to build programs in the other languages,
     # and it avoids using a stray objfile file from a long-past
     # run, for instance.
     append options " ada"
     if {[lsearch -exact $options no-force] == -1} {
 	append options " additional_flags=-f"
     }
     append options " additional_flags=-I$srcdir"

     set result [target_compile_ada_from_dir \
                     $objdir [file tail $source] $dest $type $options]

     # The Ada build always produces some output, even when the build
     # succeeds. Thus, we can not use the output the same way we do in
     # gdb_compile to determine whether the build has succeeded or not.
     # We therefore simply check whether the dest file has been created
     # or not. Unless not present, the build has succeeded.
     if [file exists $dest] { set result "" }
     return $result
 }

 # Compile some Ada code.  Generate "PASS: foo.exp: compilation SOURCE" if the
 # compile was successful.

 proc gdb_compile_ada {source dest type options} {
     set result [gdb_compile_ada_1 $source $dest $type $options]

     gdb_compile_test $source $result
     return $result
 }

 # Like standard_testfile, but for Ada.  Historically the Ada tests
 # used a different naming convention from many of the other gdb tests,
 # and this difference was preserved during the conversion to
 # standard_testfile.  DIR defaults to the base name of the test case;
 # but can be overridden to find sources in a different subdirectory of
 # gdb.ada.

 proc standard_ada_testfile {base_file {dir ""}} {
     global gdb_test_file_name srcdir subdir
     global testdir testfile srcfile binfile

     if {$dir == ""} {
 	set testdir $gdb_test_file_name
     } else {
 	set testdir $dir
     }

     set testfile $base_file
     set srcfile $srcdir/$subdir/$testdir/$testfile.adb
     set binfile [standard_output_file $testfile]
 }

 # A helper function to find the appropriate version of a tool.
 # TOOL is the tool's name, e.g., "gnatbind" or "gnatlink".

 proc find_ada_tool {tool} {
     set upper [string toupper $tool]

     set targname ${upper}_FOR_TARGET
     global $targname
     if {[info exists $targname]} {
 	return $targname
     }

     global tool_root_dir
     set root "$tool_root_dir/gcc"
     set result ""

     if {![is_remote host]} {
         set result [lookfor_file $root $tool]
 	if { $result != "" && $tool == "gnatlink" } {
 	    set result "$result --GCC=$root/xgcc -B$root"
 	}
     }

     if {$result == ""} {
         set result [transform $tool]
     }

     return $result
 }

 # Compare the GNAT version against L2 using version_compare.  If the
 # compiler does not appear to be GCC, this will always return false.

 proc gnat_version_compare {op l2} {
     set gnatmake [find_gnatmake]
     set gnatmake [lindex [split $gnatmake] 0]
     if {[catch {exec $gnatmake --version} output]} {
 	return 0
     }
     if {![regexp {GNATMAKE ([0-9]+(\.[0-9]+)*)} $output match version]} {
 	return 0
     }

     return [version_compare [split $version .] $op $l2]
 }

 # Return 1 if the GNAT runtime appears to have debug info.

 proc gnat_runtime_has_debug_info_1 { shared } {
     if { ![allow_ada_tests] } {
 	return 0
     }

     global srcdir

     set src "$srcdir/lib/gnat_debug_info_test.adb"
     set dst [standard_output_file "gnat_debug_info_test"]

     set opts {}
     lappend opts debug
     if { $shared } {
 	# Make sure we link against the shared GNAT run time.
 	set gnatbind_options [list -bargs -shared -margs]

 	foreach option $gnatbind_options {
 	    lappend opts [concat "additional_flags=" $option]
 	}
     }

     if { [gdb_compile_ada_1 $src $dst executable $opts] != "" } {
 	return 0
     }

     clean_restart
     gdb_load $dst

     if { ! [runto "GNAT_Debug_Info_Test"] } {
 	return 0
     }

     set has_debug_info 0

     gdb_test_multiple "whatis __gnat_debug_raise_exception" "" {
 	-re -wrap "type = <text variable, no debug info>" { }
 	-re -wrap "type = void" {
 	    set has_debug_info 1
 	}
 	default {
 	    # Some other unexpected output...
 	    fail $gdb_test_name
 	}
     }

     gdb_exit

     return $has_debug_info
 }

 # Return 1 if the static GNAT runtime appears to have debug info.

 gdb_caching_proc gnat_runtime_has_debug_info {} {
     return [gnat_runtime_has_debug_info_1 0]
 }

 # Return 1 if the shared GNAT runtime appears to have debug info.

 gdb_caching_proc shared_gnat_runtime_has_debug_info {} {
     return [gnat_runtime_has_debug_info_1 1]
 }

 # A helper that writes an Ada source file, then tries to compile it
 # with the given compiler options (a list like one accepted by
 # gdb_compile_ada).  Returns 1 if the flags are supported, 0
 # otherwise.
 proc ada_simple_compile {name options} {
     set src [standard_temp_file $name.adb]
     set dest [standard_temp_file $name.x]
     set f [open $src w]
     puts $f "procedure $name is"
     puts $f "begin"
     puts $f "  null;"
     puts $f "end $name;"
     close $f

     # Note that we create an executable here.  For -fvar-tracking, at
     # least, the option is supported and ignored by llvm-gnatmake --
     # but then is passed to clang during further compilation, and this
     # fails.  So to detect it we can't just stop with a .o file.
     set output [gdb_compile_ada_1 $src $dest executable $options]
     return [expr {[gdb_compile_test_nofail $output] == 1}]
 }

 # Return 1 if GNAT supports -fvar-tracking.
 gdb_caching_proc ada_fvar_tracking {} {
     return [ada_simple_compile fvar_tracking additional_flags=-fvar-tracking]
 }

 # Return 1 if GNAT supports the minimal encodings option.
 gdb_caching_proc ada_minimal_encodings {} {
     return [ada_simple_compile minimal_encodings \
 		additional_flags=-fgnat-encodings=minimal]
 }

 # Return 1 if GNAT supports -Og.
 gdb_caching_proc ada_og {} {
     return [ada_simple_compile gnat_og additional_flags=-Og]
 }

 # Return 1 if GNAT can link with -shared.
 gdb_caching_proc ada_shared_link {} {
     return [ada_simple_compile ada_shared_link {
 	additional_flags=-bargs
 	additional_flags=-shared
 	additional_flags=-margs
     }]
 }
	# Copyright 2004-2025 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/>.

	# A wrapper for foreach_with_prefix that applies suitable
	# -fgnat-encodings arguments to a command line. SCENARIO_ARG is the
	# name of a loop variable that will hold the scenario currently being
	# evaluated. FLAGS_ARG will be set to the appropriate compiler flags
	# (if any) for this scenario. LIST is the list of desired scenarios
	# to run, and BODY is what actually does the work.

	proc foreach_gnat_encoding {scenario_arg flags_arg list body} {
	# gnat-llvm does not understand -fgnat-encodings at all. However,
	# some tests examine the precise setting of the scenario -- so
	# pretend we support minimal. What is going on here is that for
	# gnat-llvm, there are no "GNAT encodings", only minimal
	# encodings, aka, real DWARF.
	set has_flag [ada_minimal_encodings]
	if {!$has_flag} {
	set list minimal
	}

	upvar 1 $scenario_arg scenario
	upvar 1 $flags_arg flags
	foreach_with_prefix scenario $list {
	set flags {}
	if {$scenario != "none" && $has_flag} {
	lappend flags additional_flags=-fgnat-encodings=$scenario
	}
	uplevel 1 $body
	}
	}

	# Call target_compile with SOURCE DEST TYPE and OPTIONS as argument,
	# after having temporarily changed the current working directory to
	# BUILDDIR.

	proc target_compile_ada_from_dir {builddir source dest type options} {
	global board
	set board [target_info name]
	set save_multilib_flag [board_info $board multilib_flags]
	set multilib_flag ""
	foreach op $save_multilib_flag {
	if { $op == "-pie" \|\| $op == "-no-pie" } {
	# Pretend gnatmake supports -pie/-no-pie, route it to
	# linker.
	append multilib_flag " -largs $op -margs"
	} else {
	append multilib_flag " $op"
	}
	}
	if { $multilib_flag != "" } {
	unset_board_info "multilib_flags"
	set_board_info multilib_flags "$multilib_flag"
	}

	catch {
	with_cwd $builddir {
	return [target_compile $source $dest $type $options]
	}
	} result options

	if { $save_multilib_flag != "" } {
	unset_board_info "multilib_flags"
	set_board_info multilib_flags $save_multilib_flag
	}

	return -options $options $result
	}

	# Compile some Ada code. Return "" if the compile was successful.
	# OPTIONS are as for target_compile, but with this addition:
	# "no-force" - do not pass -f to gnatmake. By default -f is
	# used, forcing a full recompilation.

	proc gdb_compile_ada_1 {source dest type options} {

	set srcdir [file dirname $source]
	set gprdir [file dirname $srcdir]
	set objdir [file dirname $dest]

	file delete $dest

	# Although strictly not necessary, we force the recompilation
	# of all units (additional_flags=-f). This is what is done
	# when using GCC to build programs in the other languages,
	# and it avoids using a stray objfile file from a long-past
	# run, for instance.
	append options " ada"
	if {[lsearch -exact $options no-force] == -1} {
	append options " additional_flags=-f"
	}
	append options " additional_flags=-I$srcdir"

	set result [target_compile_ada_from_dir \
	$objdir [file tail $source] $dest $type $options]

	# The Ada build always produces some output, even when the build
	# succeeds. Thus, we can not use the output the same way we do in
	# gdb_compile to determine whether the build has succeeded or not.
	# We therefore simply check whether the dest file has been created
	# or not. Unless not present, the build has succeeded.
	if [file exists $dest] { set result "" }
	return $result
	}

	# Compile some Ada code. Generate "PASS: foo.exp: compilation SOURCE" if the
	# compile was successful.

	proc gdb_compile_ada {source dest type options} {
	set result [gdb_compile_ada_1 $source $dest $type $options]

	gdb_compile_test $source $result
	return $result
	}

	# Like standard_testfile, but for Ada. Historically the Ada tests
	# used a different naming convention from many of the other gdb tests,
	# and this difference was preserved during the conversion to
	# standard_testfile. DIR defaults to the base name of the test case;
	# but can be overridden to find sources in a different subdirectory of
	# gdb.ada.

	proc standard_ada_testfile {base_file {dir ""}} {
	global gdb_test_file_name srcdir subdir
	global testdir testfile srcfile binfile

	if {$dir == ""} {
	set testdir $gdb_test_file_name
	} else {
	set testdir $dir
	}

	set testfile $base_file
	set srcfile $srcdir/$subdir/$testdir/$testfile.adb
	set binfile [standard_output_file $testfile]
	}

	# A helper function to find the appropriate version of a tool.
	# TOOL is the tool's name, e.g., "gnatbind" or "gnatlink".

	proc find_ada_tool {tool} {
	set upper [string toupper $tool]

	set targname ${upper}_FOR_TARGET
	global $targname
	if {[info exists $targname]} {
	return $targname
	}

	global tool_root_dir
	set root "$tool_root_dir/gcc"
	set result ""

	if {![is_remote host]} {
	set result [lookfor_file $root $tool]
	if { $result != "" && $tool == "gnatlink" } {
	set result "$result --GCC=$root/xgcc -B$root"
	}
	}

	if {$result == ""} {
	set result [transform $tool]
	}

	return $result
	}

	# Compare the GNAT version against L2 using version_compare. If the
	# compiler does not appear to be GCC, this will always return false.

	proc gnat_version_compare {op l2} {
	set gnatmake [find_gnatmake]
	set gnatmake [lindex [split $gnatmake] 0]
	if {[catch {exec $gnatmake --version} output]} {
	return 0
	}
	if {![regexp {GNATMAKE ([0-9]+(\.[0-9]+)*)} $output match version]} {
	return 0
	}

	return [version_compare [split $version .] $op $l2]
	}

	# Return 1 if the GNAT runtime appears to have debug info.

	proc gnat_runtime_has_debug_info_1 { shared } {
	if { ![allow_ada_tests] } {
	return 0
	}

	global srcdir

	set src "$srcdir/lib/gnat_debug_info_test.adb"
	set dst [standard_output_file "gnat_debug_info_test"]

	set opts {}
	lappend opts debug
	if { $shared } {
	# Make sure we link against the shared GNAT run time.
	set gnatbind_options [list -bargs -shared -margs]

	foreach option $gnatbind_options {
	lappend opts [concat "additional_flags=" $option]
	}
	}

	if { [gdb_compile_ada_1 $src $dst executable $opts] != "" } {
	return 0
	}

	clean_restart
	gdb_load $dst

	if { ! [runto "GNAT_Debug_Info_Test"] } {
	return 0
	}

	set has_debug_info 0

	gdb_test_multiple "whatis __gnat_debug_raise_exception" "" {
	-re -wrap "type = <text variable, no debug info>" { }
	-re -wrap "type = void" {
	set has_debug_info 1
	}
	default {
	# Some other unexpected output...
	fail $gdb_test_name
	}
	}

	gdb_exit

	return $has_debug_info
	}

	# Return 1 if the static GNAT runtime appears to have debug info.

	gdb_caching_proc gnat_runtime_has_debug_info {} {
	return [gnat_runtime_has_debug_info_1 0]
	}

	# Return 1 if the shared GNAT runtime appears to have debug info.

	gdb_caching_proc shared_gnat_runtime_has_debug_info {} {
	return [gnat_runtime_has_debug_info_1 1]
	}

	# A helper that writes an Ada source file, then tries to compile it
	# with the given compiler options (a list like one accepted by
	# gdb_compile_ada). Returns 1 if the flags are supported, 0
	# otherwise.
	proc ada_simple_compile {name options} {
	set src [standard_temp_file $name.adb]
	set dest [standard_temp_file $name.x]
	set f [open $src w]
	puts $f "procedure $name is"
	puts $f "begin"
	puts $f " null;"
	puts $f "end $name;"
	close $f

	# Note that we create an executable here. For -fvar-tracking, at
	# least, the option is supported and ignored by llvm-gnatmake --
	# but then is passed to clang during further compilation, and this
	# fails. So to detect it we can't just stop with a .o file.
	set output [gdb_compile_ada_1 $src $dest executable $options]
	return [expr {[gdb_compile_test_nofail $output] == 1}]
	}

	# Return 1 if GNAT supports -fvar-tracking.
	gdb_caching_proc ada_fvar_tracking {} {
	return [ada_simple_compile fvar_tracking additional_flags=-fvar-tracking]
	}

	# Return 1 if GNAT supports the minimal encodings option.
	gdb_caching_proc ada_minimal_encodings {} {
	return [ada_simple_compile minimal_encodings \
	additional_flags=-fgnat-encodings=minimal]
	}

	# Return 1 if GNAT supports -Og.
	gdb_caching_proc ada_og {} {
	return [ada_simple_compile gnat_og additional_flags=-Og]
	}

	# Return 1 if GNAT can link with -shared.
	gdb_caching_proc ada_shared_link {} {
	return [ada_simple_compile ada_shared_link {
	additional_flags=-bargs
	additional_flags=-shared
	additional_flags=-margs
	}]
	}