Jason Merrill <jason@redhat.com> writes:
> On 12/6/22 09:47, Gaius Mulley via Gcc-patches wrote:
>> Here are the dejagnu expect library scripts for the gm2
>> testsuite.
>
> A couple of weeks ago I noticed on a testrun that the modula tests
> didn't seem to be timing out properly, so I made this change. It
> looks like they didn't run at all in the bootstrap/test I did just
> now, so I don't know if this change is actually helpful, but here it
> is if you think it makes sense:
awesome, many thanks for the patch - it certainly looks as if the
timeout library was absent from lib/gm2.exp (and also gm2-torture.exp).
I've also applied this fix to gm2-torture.exp and will git commit/git
push your patch
regards,
Gaius
@@ -0,0 +1,498 @@
+# Copyright (C) 2003-2020 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 GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# This file was written by Gaius Mulley (gaius.mulley@southwales.ac.uk)
+# for GNU Modula-2.
+
+# we want to use libgloss so we can get find_gcc.
+load_lib libgloss.exp
+load_lib prune.exp
+load_lib gcc-defs.exp
+load_lib target-libpath.exp
+
+
+#
+# GCC_UNDER_TEST is the compiler under test.
+#
+
+#
+# default_gcc_version -- extract and print the version number of the compiler
+#
+
+proc default_gcc_version { } {
+ global GCC_UNDER_TEST
+
+ gm2_init;
+
+ # ignore any arguments after the command
+ set compiler [lindex $GCC_UNDER_TEST 0]
+
+ if ![is_remote host] {
+ set compiler_name [which $compiler];
+ } else {
+ set compiler_name $compiler;
+ }
+
+ # verify that the compiler exists
+ if { $compiler_name != 0 } then {
+ set tmp [remote_exec host "$compiler --version"]
+ set status [lindex $tmp 0];
+ set output [lindex $tmp 1];
+ regexp "version.*$" $output version
+ if { $status == 0 && [info exists version] } then {
+ clone_output "$compiler_name $version\n"
+ } else {
+ clone_output "Couldn't determine version of $compiler_name: $output\n"
+ }
+ } else {
+ # compiler does not exist (this should have already been detected)
+ warning "$compiler does not exist"
+ }
+}
+
+#
+# gcc_version -- Call default_gcc_version, so we can override it if needed.
+#
+
+proc gcc_version { } {
+ default_gcc_version;
+}
+
+#
+# gm2_init -- called at the start of each .exp script.
+#
+# There currently isn't much to do, but always using it allows us to
+# make some enhancements without having to go back and rewrite the scripts.
+#
+
+set gm2_initialized 0;
+set gm2_compile_method "default";
+set gm2_link_path "";
+set gm2_link_libraries "m2pim m2iso";
+set gm2_link_objects "";
+
+proc gm2_set_compile_method { arg } {
+ global gm2_compile_method;
+
+ send_log "********************************************\n"
+ send_log "**** setting gm2_compile_method to $arg ****\n"
+ send_log "********************************************\n"
+ set gm2_compile_method $arg;
+}
+
+
+proc gm2_init { args } {
+ global tmpdir;
+ global objdir;
+ global rootme;
+ global base_dir;
+ global tool_root_dir;
+ global gluefile wrap_flags;
+ global gm2_initialized;
+ global GCC_UNDER_TEST;
+ global TOOL_EXECUTABLE;
+ global gm2_link_libraries;
+ global gm2_link_objects;
+ global gm2_link_path;
+ global HAVE_LIBSTDCXX_V3;
+
+ if { $gm2_initialized == 1 } { return; }
+
+ set gm2_link_objects "";
+ set GCC_UNDER_TEST [lookfor_file $rootme gm2];
+ append GCC_UNDER_TEST " " -B[file dirname $rootme]/gcc " " ${args};
+ append GCC_UNDER_TEST " " -fno-diagnostics-show-caret
+ append GCC_UNDER_TEST " " -fno-diagnostics-show-line-numbers
+ append GCC_UNDER_TEST " " -fdiagnostics-color=never
+ send_log "GCC_UNDER_TEST is ${GCC_UNDER_TEST}\n"
+
+ if ![info exists tmpdir] then {
+ set tmpdir /tmp;
+ }
+ if {[target_info needs_status_wrapper] != "" && \
+ [target_info needs_status_wrapper] != "0" && \
+ ![info exists gluefile]} {
+ set gluefile ${tmpdir}/gcc-testglue.o;
+ set result [build_wrapper $gluefile];
+ if { $result != "" } {
+ set gluefile [lindex $result 0];
+ set wrap_flags [lindex $result 1];
+ } else {
+ unset gluefile
+ }
+ }
+
+ set gm2_link_path "[gm2_link_flags [get_multilibs]]";
+ verbose $gm2_link_path 1
+}
+
+#
+# gm2_target_compile_default -- compile a source file
+#
+
+proc gm2_target_compile_default { source dest type options } {
+ global gluefile wrap_flags
+ global GCC_UNDER_TEST
+ global TOOL_OPTIONS
+ global TEST_ALWAYS_FLAGS
+ global gm2_link_objects
+ global gm2_link_libraries
+ global gm2_link_path
+
+ if {[target_info needs_status_wrapper] != "" && \
+ [target_info needs_status_wrapper] != "0" && \
+ [info exists gluefile] } {
+ lappend options "libs=${gluefile}"
+ lappend options "ldflags=$wrap_flags"
+ }
+
+ # TEST_ALWAYS_FLAGS are flags that should be passed to every
+ # compilation. They are passed first to allow individual
+ # tests to override them.
+ if [info exists TEST_ALWAYS_FLAGS] {
+ set options [concat "{additional_flags=$TEST_ALWAYS_FLAGS}" $options]
+ }
+
+ global TEST_EXTRA_LIBS
+ if [info exists TEST_EXTRA_LIBS] {
+ lappend options "ldflags=$TEST_EXTRA_LIBS"
+ }
+
+ if [target_info exists gcc,stack_size] {
+ lappend options "additional_flags=-DSTACK_SIZE=[target_info gcc,stack_size]"
+ }
+ if [target_info exists gcc,no_trampolines] {
+ lappend options "additional_flags=-DNO_TRAMPOLINES"
+ }
+ if [target_info exists gcc,no_label_values] {
+ lappend options "additional_flags=-DNO_LABEL_VALUES"
+ }
+ if [info exists TOOL_OPTIONS] {
+ lappend options "additional_flags=$TOOL_OPTIONS"
+ }
+ if [target_info exists gcc,timeout] {
+ lappend options "timeout=[target_info gcc,timeout]"
+ }
+ lappend options "compiler=$GCC_UNDER_TEST"
+ # puts stderr "options = $options\n"
+ # puts stderr "***** target_compile: $source $dest $type $options\n"
+ return [target_compile $source $dest $type $options]
+}
+
+
+#
+# gm2_target_compile -- compile a source file
+#
+
+proc gm2_target_compile { source dest type options } {
+ global gm2_compile_method;
+
+ return [gm2_target_compile_${gm2_compile_method} $source $dest $type $options]
+}
+
+#
+# gm2_link_lib - allows tests to specify link libraries.
+# This _must_ be called before gm2_init.
+#
+
+proc gm2_link_lib { libraries } {
+ global gm2_link_libraries;
+
+ set gm2_link_libraries $libraries;
+}
+
+
+#
+# gm2_link_obj - allows tests to specify link with objects.
+#
+
+proc gm2_link_obj { objects } {
+ global gm2_link_objects;
+
+ set gm2_link_objects $objects;
+}
+
+
+#
+# gm2_link_flags - detects the whereabouts of libraries (-lstdc++).
+#
+
+proc gm2_link_flags { paths } {
+ global srcdir;
+ global ld_library_path;
+ global gccpath;
+ global gm2_link_libraries;
+
+ set gccpath ${paths}
+ set libio_dir ""
+ set flags ""
+ set ld_library_path "."
+
+ set shlib_ext [get_shlib_extension]
+ verbose "shared lib extension: $shlib_ext"
+
+ if { $gccpath == "" } {
+ global tool_root_dir
+
+ set libstdcpp [lookfor_file ${tool_root_dir} libstdc++]
+ if { $libstdcpp != "" } {
+ append flags "-L${libstdcpp} "
+ append ld_library_path ":${libstdcpp}"
+ }
+ } else {
+ if [file exists "${gccpath}/lib/libstdc++.a"] {
+ append ld_library_path ":${gccpath}/lib"
+ }
+ if [file exists "${gccpath}/libstdc++/libstdc++.a"] {
+ append flags "-L${gccpath}/libstdc++ "
+ append ld_library_path ":${gccpath}/libstdc++"
+ }
+ if [file exists "${gccpath}/libstdc++-v3/src/.libs/libstdc++.a"] {
+ append flags " -L${gccpath}/libstdc++-v3/src/.libs "
+ append ld_library_path ":${gccpath}/libstdc++-v3/src/.libs"
+ }
+ # Look for libstdc++.${shlib_ext}.
+ if [file exists "${gccpath}/libstdc++-v3/src/.libs/libstdc++.${shlib_ext}"] {
+ append flags " -L${gccpath}/libstdc++-v3/src/.libs "
+ append ld_library_path ":${gccpath}/libstdc++-v3/src/.libs"
+ }
+
+ # puts stderr "${gm2_link_libraries} before foreach"
+ foreach d [list {*}${gm2_link_libraries}] {
+ # puts stderr "${d} XXXX"
+ send_log "ld_library_path was ${ld_library_path}\n"
+ send_log "looking for ${gccpath}/lib${d}/.libs/lib${d}.a\n"
+ if [file exists "${gccpath}/libgm2/lib${d}/.libs/lib${d}.a"] {
+ send_log "good found ${gccpath}/libgm2/lib${d}/.libs/lib${d}.a\n"
+ # append flags " -L${gccpath}/libgm2/lib${d}/.libs -l${d}"
+ append flags " ${gccpath}/libgm2/lib${d}/.libs/lib${d}.a"
+ append ld_library_path ":${gccpath}/libgm2/lib${d}/.libs"
+ }
+ send_log "ld_library_path is ${ld_library_path}\n"
+ }
+ }
+
+ set_ld_library_path_env_vars
+ return "$flags"
+}
+
+
+#
+# gm2_init_pimx - set the default libraries to choose PIM and then ISO.
+# choose Modula-2, dialect.
+#
+#
+
+proc gm2_init_pimx { dialect {path ""} args } {
+ global srcdir;
+ global gccpath;
+
+ set gm2src ${srcdir}/../m2;
+
+ send_log "srcdir is $srcdir\n"
+ send_log "gccpath is $gccpath\n"
+ send_log "gm2src is $gm2src\n"
+
+ set pimIpath "${gccpath}/libgm2/libm2pim:${gm2src}/gm2-libs";
+ set pimLpath "${gccpath}/libgm2/libm2pim/.libs";
+
+ set isoIpath "${gccpath}/libgm2/libm2iso:${gm2src}/gm2-libs-iso";
+ set isoLpath "${gccpath}/libgm2/libm2iso/.libs";
+
+ set theIpath "-I${pimIpath} -I${isoIpath}";
+ set theLpath "-L${pimLpath} -L${isoLpath}";
+
+ if { $path != "" } then {
+ append theIpath " -I"
+ append theIpath ${path}
+ }
+ gm2_init {*}${theIpath} {*}${dialect} {*}${theLpath} {*}${args};
+}
+
+#
+# gm2_init_pim - set the default libraries to choose PIM and then ISO.
+#
+#
+
+proc gm2_init_pim { {path ""} args } {
+ gm2_init_pimx -fpim {*}${path} {*}${args};
+}
+
+
+#
+# gm2_init_pim2 - set the default libraries to choose PIM and then ISO.
+# It uses the PIM2 dialect.
+#
+
+proc gm2_init_pim2 { {path ""} args } {
+ gm2_init_pimx -fpim2 {*}${path} {*}${args};
+}
+
+
+#
+# gm2_init_pim3 - set the default libraries to choose PIM and then ISO.
+# It uses the PIM3 dialect.
+#
+
+proc gm2_init_pim3 { {path ""} args } {
+ gm2_init_pimx -fpim3 {*}${path} {*}${args};
+}
+
+
+#
+# gm2_init_pim4 - set the default libraries to choose PIM and then ISO.
+# It uses the PIM4 dialect.
+#
+
+proc gm2_init_pim4 { {path ""} args } {
+ gm2_init_pimx -fpim4 {*}${path} {*}${args};
+}
+
+
+#
+# gm2_init_iso - set the default libraries to choose ISO and then PIM.
+#
+
+proc gm2_init_iso { {path ""} args } {
+ global srcdir;
+ global gccpath;
+
+ set gm2src ${srcdir}/../m2;
+
+ set isoIpath "${gccpath}/libgm2/libm2iso:${gm2src}/gm2-libs-iso";
+ set pimIpath "${gccpath}/libgm2/libm2pim:${gm2src}/gm2-libs";
+
+ set isoLpath "${gccpath}/libgm2/libm2iso/.libs";
+ set pimLpath "${gccpath}/libgm2/libm2pim/.libs";
+
+ set corIpath "${gccpath}/libgm2/libm2cor:${gm2src}/gm2-libs-coroutines";
+ set corLpath "${gccpath}/libgm2/libm2cor/.libs";
+
+ set theIpath "-I${isoIpath} -I${corIpath} -I${pimIpath}";
+ set theLpath "-L${isoLpath} -L${corLpath} -L${pimLpath}";
+
+ if { $path != "" } then {
+ append theIpath " -I"
+ append theIpath ${path}
+ }
+
+ gm2_init {*}${theIpath} -fiso {*}${theLpath} {*}${args};
+}
+
+
+#
+# gm2_init_ulm - set the default libraries to choose the ULM and PIM libraries.
+#
+
+proc gm2_init_ulm { {path ""} args } {
+ global srcdir;
+ global gccpath;
+
+ set gm2src ${srcdir}/../m2;
+
+ set ulmIpath "${gccpath}/libgm2/libm2ulm:${gm2src}/ulm-lib-gm2/std:${gm2src}/ulm-lib-gm2/sys";
+ set ulmLpath "${gccpath}/libgm2/libm2ulm/.libs";
+
+ set pimIpath "${gccpath}/libgm2/libm2pim:${gm2src}/gm2-libs";
+ set pimLpath "${gccpath}/libgm2/libm2pim/.libs";
+
+ set theIpath "-I${ulmIpath} -I${pimIpath}";
+ set theLpath "-L${ulmLpath} -L${pimLpath}";
+
+ if { $path != "" } then {
+ append theIpath " -I"
+ append theIpath ${path}
+ }
+
+ gm2_init {*}${theIpath} -fpim {*}${theLpath} {*}${args};
+}
+
+
+#
+# gm2_init_log - set the default libraries to choose LOG and then PIM.
+#
+#
+
+proc gm2_init_log { {path ""} args } {
+ global srcdir;
+ global gccpath;
+
+ set gm2src ${srcdir}/../m2;
+
+ send_log "srcdir is $srcdir\n"
+ send_log "gccpath is $gccpath\n"
+ send_log "gm2src is $gm2src\n"
+
+ set logIpath "${gccpath}/libgm2/libm2log:${gm2src}/gm2-libs-pim";
+ set logLpath "${gccpath}/libgm2/libm2log/.libs";
+
+ set pimIpath "${gccpath}/libgm2/libm2pim:${gm2src}/gm2-libs";
+ set pimLpath "${gccpath}/libgm2/libm2pim/.libs";
+
+ set isoIpath "${gccpath}/libgm2/libm2iso:${gm2src}/gm2-libs-iso";
+ set pimIpath "${gccpath}/libgm2/libm2pim:${gm2src}/gm2-libs";
+
+ set theIpath "-I${logIpath} -I${pimIpath} -I${isoIpath}";
+ set theLpath "-L${logLpath} -L${pimLpath}";
+
+ if { $path != "" } then {
+ append theIpath " -I"
+ append theIpath ${path}
+ }
+
+ gm2_link_lib "m2log m2pim m2iso"
+ gm2_init {*}${theIpath} -fpim {*}${theLpath} {*}${args};
+}
+
+#
+# gm2_init_cor - set the default libraries to choose COR and then PIM.
+#
+#
+
+proc gm2_init_cor { {path ""} args } {
+ global srcdir;
+ global gccpath;
+ global gm2_link_libraries;
+
+ set gm2src ${srcdir}/../m2;
+
+ send_log "srcdir is $srcdir\n"
+ send_log "gccpath is $gccpath\n"
+ send_log "gm2src is $gm2src\n"
+
+ set corIpath "${gccpath}/libgm2/libm2cor:${gm2src}/gm2-libs-coroutines";
+ set corLpath "${gccpath}/libgm2/libm2cor/.libs";
+
+ set pimIpath "${gccpath}/libgm2/libm2pim:${gm2src}/gm2-libs";
+ set pimLpath "${gccpath}/libgm2/libm2pim/.libs";
+
+ set isoIpath "${gccpath}/libgm2/libm2iso:${gm2src}/gm2-libs-iso";
+ set isoLpath "${gccpath}/libgm2/libm2iso/.libs";
+
+ set logIpath "${gccpath}/libgm2/libm2log:${gm2src}/gm2-libs-pim";
+ set logLpath "${gccpath}/libgm2/libm2log/.libs";
+
+ set theIpath "-I${corIpath} -I${pimIpath} -I${logIpath} -I${isoIpath}";
+ set theLpath "-L${corLpath} -L${pimLpath} -L${logLpath} -L${isoLpath}";
+
+ if { $path != "" } then {
+ append theIpath " -I"
+ append theIpath ${path}
+ }
+
+ gm2_link_lib "m2cor m2pim m2iso"
+ gm2_init {*}${theIpath} -fpim {*}${theLpath} {*}${args};
+}
@@ -0,0 +1,77 @@
+# Copyright (C) 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
+# 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 GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+load_lib gcc-dg.exp
+
+# Define gm2 callbacks for dg.exp.
+
+proc gm2-dg-test { prog do_what extra_tool_flags } {
+ verbose "begin:gm2-dg-test" 1
+ upvar dg-do-what dg-do-what
+
+ # For now demote link and run tests to compile-only.
+ switch $do_what {
+ link -
+ run {
+ set do_what compile
+ set dg-do-what compile
+ }
+ }
+
+ set result \
+ [gcc-dg-test-1 gm2_target_compile $prog $do_what $extra_tool_flags]
+
+ set comp_output [lindex $result 0]
+ set output_file [lindex $result 1]
+ verbose "end:gm2-dg-test" 1
+ return [list $comp_output $output_file]
+}
+
+proc gm2-dg-prune { system text } {
+ return [gcc-dg-prune $system $text]
+}
+
+# Utility routines.
+
+# Modified dg-runtest that can cycle through a list of optimization options
+# as c-torture does.
+proc gm2-dg-runtest { testcases flags default-extra-flags } {
+ global runtests
+ global TORTURE_OPTIONS
+
+ foreach test $testcases {
+ # If we're only testing specific files and this isn't one of
+ # them, skip it.
+ if ![runtest_file_p $runtests $test] {
+ continue
+ }
+
+ # look if this is dg-do-run test, in which case
+ # we cycle through the option list, otherwise we don't
+ if [expr [search_for $test "dg-do run"]] {
+ set option_list $TORTURE_OPTIONS
+ } else {
+ set option_list [list { -O } ]
+ }
+
+ set nshort [file tail [file dirname $test]]/[file tail $test]
+
+ foreach flags_t $option_list {
+ verbose "Testing $nshort, $flags $flags_t" 1
+ dg-test $test "$flags $flags_t" ${default-extra-flags}
+ }
+ }
+}
@@ -0,0 +1,137 @@
+# Copyright (C) 2003-2020 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 GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# This file was written by Gaius Mulley (gaius.mulley@southwales.ac.uk)
+# for GNU Modula-2
+
+load_lib file-format.exp
+load_lib gm2.exp
+
+#
+# gm2-simple-compile -- runs the compiler
+#
+# SRC is the full pathname of the testcase.
+# OPTION is the specific compiler flag we're testing (eg: -O2).
+#
+proc gm2-simple-compile { src option } {
+ global output
+ global srcdir tmpdir
+ global host_triplet
+
+ set output "$tmpdir/[file tail [file rootname $src]].o"
+
+ regsub "^$srcdir/?" $src "" testcase
+ # If we couldn't rip $srcdir out of `src' then just do the best we can.
+ # The point is to reduce the unnecessary noise in the logs. Don't strip
+ # out too much because different testcases with the same name can confuse
+ # `test-tool'.
+ if [string match "/*" $testcase] {
+ set testcase "[file tail [file dirname $src]]/[file tail $src]"
+ }
+
+ verbose "Testing $testcase, $option" 1
+
+ # Run the compiler and analyze the results.
+ set options ""
+ lappend options "additional_flags=$option"
+
+ set comp_output [gm2_target_compile "$src" "$output" object $options];
+ gm2_check_compile $testcase $option $output $comp_output
+ remote_file build delete $output
+ verbose "$comp_output" 1
+}
+
+
+#
+# gm2-simple-execute -- utility to compile and execute a testcase
+#
+# SOURCES is a list of full pathnames to the test source files.
+# The first filename in this list forms the "testcase".
+#
+# If the testcase has an associated .x file, we source that to run the
+# test instead. We use .x so that we don't lengthen the existing filename
+# to more than 14 chars.
+#
+proc gm2-simple-execute { sources args option } {
+ global tmpdir tool srcdir output compiler_conditional_xfail_data;
+ global gm2_link_libraries;
+ global gm2_link_path;
+ global gm2_link_objects;
+
+ # Use the first source filename given as the filename under test.
+ set src [lindex $sources 0];
+
+ if { [llength $args] > 0 } {
+ set additional_flags [lindex $args 0];
+ } else {
+ set additional_flags "";
+ }
+ # Check for alternate driver.
+ if [file exists [file rootname $src].x] {
+ verbose "Using alternate driver [file rootname [file tail $src]].x" 2
+ set done_p 0;
+ catch "set done_p \[source [file rootname $src].x\]"
+ if { $done_p } {
+ return
+ }
+ }
+
+ set executable $tmpdir/[file tail [file rootname $src].x];
+ set objectfile $tmpdir/[file tail [file rootname $src].o];
+
+ regsub "^$srcdir/?" $src "" testcase
+ # If we couldn't rip $srcdir out of `src' then just do the best we can.
+ # The point is to reduce the unnecessary noise in the logs. Don't strip
+ # out too much because different testcases with the same name can confuse
+ # `test-tool'.
+ if [string match "/*" $testcase] {
+ set testcase "[file tail [file dirname $src]]/[file tail $src]"
+ }
+
+ set execname "${executable}";
+
+ remote_file build delete $execname;
+ verbose "Testing $testcase, $option" 1
+
+ # start by setting options with option
+ set options [concat "{additional_flags=$gm2_link_objects} " $option]
+ # now append path -fno-libs=- and objects
+ set options [concat "{additional_flags=$gm2_link_path} " $options]
+ set options [concat "{additional_flags=-fno-libs=-} " $options]
+ set options [concat "{additional_flags=$gm2_link_objects} " $options]
+
+ set comp_output [gm2_target_compile "${sources}" "${execname}" executable ${options}];
+
+ if ![gm2_check_compile "${testcase} compilation" ${option} ${execname} $comp_output] {
+ unresolved "${testcase} execution, ${option}"
+ remote_file build delete $objectfile
+ return 0
+ }
+
+ set result [gm2_load "$execname" "" ""]
+
+ set status [lindex $result 0];
+ set output [lindex $result 1];
+ if { $status == "fail" } {
+ ${tool}_fail $testcase $option
+ send_log "executed $execname with result $status"
+ }
+ if { $status == "pass" } {
+ ${tool}_pass $testcase $option
+ remote_file build delete $execname;
+ }
+ return 1
+}
@@ -0,0 +1,538 @@
+# Copyright (C) 2003-2020 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 GCC; see the file COPYING3. If not see
+# <http://www.gnu.org/licenses/>.
+
+# This file was written by Rob Savoye. (rob@cygnus.com)
+# and modified by Gaius Mulley (gaius.mulley@southwales.ac.uk)
+# for GNU Modula-2
+
+load_lib file-format.exp
+load_lib target-libpath.exp
+
+# The default option list can be overridden by
+# TORTURE_OPTIONS="{ { list1 } ... { listN } }"
+
+if ![info exists TORTURE_OPTIONS] {
+ # It is theoretically beneficial to group all of the O2/O3 options together,
+ # as in many cases the compiler will generate identical executables for
+ # all of them--and the c-torture testsuite will skip testing identical
+ # executables multiple times.
+ # Also note that -finline-functions is explicitly included in one of the
+ # items below, even though -O3 is also specified, because some ports may
+ # choose to disable inlining functions by default, even when optimizing.
+ set TORTURE_OPTIONS [list \
+ { -g } \
+ { -O } \
+ { -O -g } \
+ { -Os } \
+ { -O3 -fomit-frame-pointer } \
+ { -O3 -fomit-frame-pointer -finline-functions } ]
+}
+
+
+#
+# very costly options follow
+#
+# set TORTURE_OPTIONS [list \
+\# { -g } \
+\# { -O } \
+\# { -O -g } \
+\# { -Os } \
+\# { -Os -g } \
+\# { -O0 } \
+\# { -O0 -g } \
+\# { -O1 } \
+\# { -O1 -g } \
+\# { -O2 } \
+\# { -O2 -g } \
+\# { -O3 } \
+\# { -O3 -g } \
+\# { -O3 -fomit-frame-pointer } \
+\# { -O3 -fomit-frame-pointer -finline-functions } ]
+#
+#
+#
+
+
+
+#
+# gm2-torture-compile -- runs the gm2-torture test
+#
+# SRC is the full pathname of the testcase.
+# OPTION is the specific compiler flag we're testing (eg: -O2).
+#
+proc gm2-torture-compile { src option } {
+ global output
+ global srcdir tmpdir
+ global host_triplet
+
+ set output "$tmpdir/[file tail [file rootname $src]].o"
+
+ regsub "^$srcdir/?" $src "" testcase
+ # If we couldn't rip $srcdir out of `src' then just do the best we can.
+ # The point is to reduce the unnecessary noise in the logs. Don't strip
+ # out too much because different testcases with the same name can confuse
+ # `test-tool'.
+ if [string match "/*" $testcase] {
+ set testcase "[file tail [file dirname $src]]/[file tail $src]"
+ }
+
+ # puts stderr "gm2-torture-compiler src = $src, option = $option\n"
+
+ # Run the compiler and analyze the results.
+ set options ""
+ lappend options "additional_flags=${option}"
+
+ set comp_output [gm2_target_compile "$src" "$output" object $options];
+ # puts stderr "*** gm2 torture compile: $comp_output ${options} "
+ gm2_check_compile $testcase "$option" $output $comp_output
+ remote_file build delete $output
+ verbose "$comp_output" 1
+}
+
+
+#
+# gm2_check_compile_fail -- Reports and returns pass/fail for a compilation
+#
+
+proc gm2_check_compile_fail {testcase option objname gcc_output} {
+ global tool
+ set fatal_signal "*cc: Internal compiler error: program*got fatal signal"
+
+ if [string match "$fatal_signal 6" $gcc_output] then {
+ ${tool}_fail $testcase "Got Signal 6, $option"
+ return 0
+ }
+
+ if [string match "$fatal_signal 11" $gcc_output] then {
+ ${tool}_fail $testcase "Got Signal 11, $option"
+ return 0
+ }
+
+# # We shouldn't get these because of -w, but just in case.
+# if [string match "*cc:*warning:*" $gcc_output] then {
+# warning "$testcase: (with warnings) $option"
+# send_log "$gcc_output\n"
+# unresolved "$testcase, $option"
+# return 0
+# }
+
+ set gcc_output [prune_warnings $gcc_output]
+
+ set unsupported_message [${tool}_check_unsupported_p $gcc_output]
+ if { $unsupported_message != "" } {
+ unsupported "$testcase: $unsupported_message"
+ return 0
+ }
+
+ # remove any leftover LF/CR to make sure any output is legit
+ regsub -all -- "\[\r\n\]*" $gcc_output "" gcc_output
+
+ # check for any internal error
+ if { [string match "internal error" $gcc_output] ||
+ [string match "internal compiler error" $gcc_output] } then {
+ ${tool}_fail $testcase $option
+ return 0
+ }
+
+ # If any message remains, we pass, as it will be the error message
+ if ![string match "" $gcc_output] then {
+ ${tool}_pass $testcase $option
+ return 1
+ }
+
+ # a clean compilation means this test has failed
+ ${tool}_fail $testcase $option
+ return 1
+}
+
+#
+# gm2-torture-compile-fail -- runs the gm2-torture test
+#
+# SRC is the full pathname of the testcase.
+# OPTION is the specific compiler flag we're testing (eg: -O2).
+#
+proc gm2-torture-compile-fail { src option } {
+ global output
+ global srcdir tmpdir
+ global host_triplet
+
+ # puts stderr "gm2-torture-compile-fail: ${option}\n"
+ set output "$tmpdir/[file tail [file rootname $src]].o"
+
+ regsub "^$srcdir/?" $src "" testcase
+ # If we couldn't rip $srcdir out of `src' then just do the best we can.
+ # The point is to reduce the unnecessary noise in the logs. Don't strip
+ # out too much because different testcases with the same name can confuse
+ # `test-tool'.
+ if [string match "/*" $testcase] {
+ set testcase "[file tail [file dirname $src]]/[file tail $src]"
+ }
+
+ verbose "Testing expected failure $testcase, $option" 1
+
+ # Run the compiler and analyze the results.
+ set options ""
+ set additional_flags ""
+ lappend options "additional_flags=$option" # do not use -w for gm2
+ if { $additional_flags != "" } {
+ lappend options "additional_flags=$additional_flags"
+ }
+
+ set comp_output [gm2_target_compile "$src" "$output" object $options];
+ gm2_check_compile_fail $testcase $option $output $comp_output
+ remote_file build delete $output
+ verbose "$comp_output" 1
+}
+
+#
+# gm2-torture-execute -- utility to compile and execute a testcase
+#
+# SOURCES is a list of full pathnames to the test source files.
+# The first filename in this list forms the "testcase".
+#
+# If the testcase has an associated .x file, we source that to run the
+# test instead. We use .x so that we don't lengthen the existing filename
+# to more than 14 chars.
+#
+proc gm2-torture-execute { sources args success } {
+ global tmpdir tool srcdir output compiler_conditional_xfail_data;
+ global TORTURE_OPTIONS;
+ global gm2_link_libraries;
+ global gm2_link_objects;
+ global gm2_link_path;
+
+ # Use the first source filename given as the filename under test.
+ set src [lindex $sources 0];
+
+ if { [llength $args] > 0 } {
+ set additional_flags [lindex $args 0];
+ } else {
+ set additional_flags "";
+ }
+ # Check for alternate driver.
+ if [file exists [file rootname $src].x] {
+ verbose "Using alternate driver [file rootname [file tail $src]].x" 2
+ set done_p 0;
+ catch "set done_p \[source [file rootname $src].x\]"
+ if { $done_p } {
+ return
+ }
+ }
+
+ set executable $tmpdir/[file tail [file rootname $src].x];
+ set objectfile $tmpdir/[file tail [file rootname $src].o];
+
+ regsub "^$srcdir/?" $src "" testcase
+ # If we couldn't rip $srcdir out of `src' then just do the best we can.
+ # The point is to reduce the unnecessary noise in the logs. Don't strip
+ # out too much because different testcases with the same name can confuse
+ # `test-tool'.
+ if [string match "/*" $testcase] {
+ set testcase "[file tail [file dirname $src]]/[file tail $src]"
+ }
+
+ set option_list $TORTURE_OPTIONS;
+
+ set count 0;
+ set oldstatus "foo";
+ foreach option $option_list {
+ if { $count > 0 } {
+ set oldexec $execname;
+ }
+ set execname "${executable}${count}";
+ incr count;
+
+ # torture_{compile,execute}_xfail are set by the .x script
+ # (if present)
+ if [info exists torture_compile_xfail] {
+ setup_xfail $torture_compile_xfail
+ }
+
+ # torture_execute_before_{compile,execute} can be set by the .x script
+ # (if present)
+ if [info exists torture_eval_before_compile] {
+ set ignore_me [eval $torture_eval_before_compile]
+ }
+
+ remote_file build delete $execname;
+ verbose "Testing $testcase, $option" 1
+
+ set options ""
+ lappend options "additional_flags=$option"
+ if { $additional_flags != "" } {
+ lappend options "additional_flags=$additional_flags"
+ }
+ set comp_output [gm2_target_compile "$sources" "${objectfile}" object "$options"];
+
+ # puts stderr "torture gm2 case: $comp_output ${options} "
+
+ if ![gm2_check_compile "$testcase compilation" ${options} $objectfile $comp_output] {
+ unresolved "$testcase execution, ${options}"
+ send_log "compile failed not attempting link\n"
+ remote_file build delete $objectfile
+ continue
+ }
+
+ send_log "finished compile now attempting link\n"
+ # now link the test
+ set options ${option};
+
+ if { [llength ${args}] > 0 } {
+ lappend options "additional_flags=[lindex ${args} 0]"
+ }
+
+ lappend options " additional_flags=${gm2_link_path}"
+
+ if {$gm2_link_path != ""} {
+ lappend options " ldflags=$gm2_link_path"
+ }
+
+ if {$gm2_link_libraries != ""} {
+ lappend options " ldflags=$gm2_link_libraries"
+ }
+
+# lappend options "ldflags=/home/gaius/GM2/graft-combine/build-devel-modula2-enabled/x86_64-pc-linux-gnu/libgm2/libm2pim/.libs/libm2pim.a"
+# lappend options "ldflags=/home/gaius/GM2/graft-combine/build-devel-modula2-enabled/x86_64-pc-linux-gnu/libgm2/libm2iso/.libs/libm2iso.a"
+# lappend options "ldflags=-lm2pim -lm2iso"
+#
+ if {$gm2_link_objects != ""} {
+ lappend options " additional_flags=${gm2_link_objects}"
+ }
+ if {$gm2_link_path != ""} {
+ lappend options " additional_flags=${gm2_link_path}"
+ }
+
+ # lappend options " additional_flags=${gm2_link_objects}"
+ # lappend options " additional_flags=${gm2_link_path}"
+ # lappend options " additional_flags=${gm2_link_libraries}"
+ set options [concat "{additional_flags=$gm2_link_path} " $options]
+ set options [concat "{additional_flags=-fno-libs=-} " $options]
+ set options [concat "{additional_flags=$gm2_link_objects} " $options]
+ # set options [concat "{additional_flags=$gm2_link_libraries} " $options]
+
+ send_log "gm2_link_path = $gm2_link_path\n"
+ send_log "attempting link\n"
+ set comp_output [gm2_target_compile "${sources}" "${execname}" executable ${options}];
+ # puts "Link libraries are: ${gm2_link_libraries}"
+ # puts "Link path is : ${gm2_link_path}"
+
+ if ![gm2_check_compile "${testcase} compilation" ${option} ${execname} ${comp_output}] {
+ send_log "unsuccessful link\n"
+ unresolved "${testcase} execution, ${option} (link failed)"
+ verbose "tried to link ${testcase} ${sources} ${execname} executable ${options}" 1
+ verbose "Link libraries are: ${gm2_link_libraries}" 1
+ verbose "Link path is : ${gm2_link_path}" 1
+ verbose "$comp_output" 1
+ lappend options "additional_flags=-fsources"
+ lappend options "additional_flags=-v"
+ verbose "****** s t a r t *********" 1
+ set comp_output [gm2_target_compile "$sources" "${objectfile}" object ${options}];
+ verbose "$comp_output" 1
+ set comp_output [gm2_target_compile "${sources}" "${execname}" executable ${options}];
+ verbose "$comp_output" 1
+ verbose "****** e n d *********" 1
+ remote_file build delete $execname
+ remote_file build delete $objectfile
+ continue
+ }
+
+ send_log "successful link\n"
+ # See if this source file uses "long long" types, if it does, and
+ # no_long_long is set, skip execution of the test.
+ if [target_info exists no_long_long] then {
+ if [expr [search_for $src "long long"]] then {
+ unsupported "$testcase execution, $option"
+ continue
+ }
+ }
+
+ if [info exists torture_execute_xfail] {
+ setup_xfail $torture_execute_xfail
+ }
+
+ if [info exists torture_eval_before_execute] {
+ set ignore_me [eval $torture_eval_before_execute]
+ }
+
+ # Sometimes we end up creating identical executables for two
+ # consecutive sets of different of compiler options.
+ #
+ # In such cases we know the result of this test will be identical
+ # to the result of the last test.
+ #
+ # So in cases where the time to load and run/simulate the test
+ # is relatively high, compare the two binaries and avoid rerunning
+ # tests if the executables are identical.
+ #
+ # Do not do this for native testing since the cost to load/execute
+ # the test is fairly small and the comparison step actually slows
+ # the entire process down because it usually does not "hit".
+ set skip 0;
+ if { ![isnative] && [info exists oldexec] } {
+ if { [remote_file build cmp $oldexec $execname] == 0 } {
+ set skip 1;
+ }
+ }
+ if { $skip == 0 } {
+ set result [gm2_load "$execname" "" ""]
+ set status [lindex $result 0];
+ set output [lindex $result 1];
+ if { $success == "fail" } {
+ # invert the result
+ if { $status == "pass" } {
+ set status "fail"
+ } else {
+ set status "pass"
+ }
+ }
+ send_log "executed $execname with result $status"
+ }
+ if { $oldstatus == "pass" } {
+ remote_file build delete $oldexec;
+ }
+ $status "$testcase execution, $option"
+ set oldstatus $status;
+ }
+ if [info exists status] {
+ if { $status == "pass" } {
+ remote_file build delete $execname;
+ remote_file build delete $objectfile;
+ }
+ }
+}
+
+#
+# search_for -- looks for a string match in a file
+#
+proc search_for { file pattern } {
+ set fd [open $file r]
+ while { [gets $fd cur_line]>=0 } {
+ if [string match "*$pattern*" $cur_line] then {
+ close $fd
+ return 1
+ }
+ }
+ close $fd
+ return 0
+}
+
+#
+# gm2-torture -- the gm2-torture testcase source file processor
+#
+# This runs compilation only tests (no execute tests).
+# SRC is the full pathname of the testcase, or just a file name in which case
+# we prepend $srcdir/$subdir.
+#
+# If the testcase has an associated .x file, we source that to run the
+# test instead. We use .x so that we don't lengthen the existing filename
+# to more than 14 chars.
+#
+proc gm2-torture { args } {
+ global srcdir subdir compiler_conditional_xfail_data TORTURE_OPTIONS
+
+ set src [lindex $args 0];
+ if { [llength $args] > 1 } {
+ set options [lindex $args 1];
+ } else {
+ set options ""
+ }
+
+ # Prepend $srdir/$subdir if missing.
+ if ![string match "*/*" $src] {
+ set src "$srcdir/$subdir/$src"
+ }
+
+ # Check for alternate driver.
+ if [file exists [file rootname $src].x] {
+ verbose "Using alternate driver [file rootname [file tail $src]].x" 2
+ set done_p 0
+ catch "set done_p \[source [file rootname $src].x\]"
+ if { $done_p } {
+ return
+ }
+ }
+
+ set option_list $TORTURE_OPTIONS
+
+ # loop through all the options
+ foreach option $option_list {
+ # torture_compile_xfail is set by the .x script (if present)
+ if [info exists torture_compile_xfail] {
+ setup_xfail $torture_compile_xfail
+ }
+
+ # torture_execute_before_compile is set by the .x script (if present)
+ if [info exists torture_eval_before_compile] {
+ set ignore_me [eval $torture_eval_before_compile]
+ }
+
+ gm2-torture-compile $src "$option $options"
+ }
+}
+
+#
+# gm2-torture -- the gm2-torture testcase source file processor
+#
+# This runs compilation only tests (no execute tests).
+# SRC is the full pathname of the testcase, or just a file name in which case
+# we prepend $srcdir/$subdir.
+#
+# If the testcase has an associated .x file, we source that to run the
+# test instead. We use .x so that we don't lengthen the existing filename
+# to more than 14 chars.
+#
+proc gm2-torture-fail { args } {
+ global srcdir subdir compiler_conditional_xfail_data TORTURE_OPTIONS
+
+ set src [lindex $args 0];
+ if { [llength $args] > 1 } {
+ set options [lindex $args 1];
+ } else {
+ set options ""
+ }
+
+ # Prepend $srdir/$subdir if missing.
+ if ![string match "*/*" $src] {
+ set src "$srcdir/$subdir/$src"
+ }
+
+ # Check for alternate driver.
+ if [file exists [file rootname $src].x] {
+ verbose "Using alternate driver [file rootname [file tail $src]].x" 2
+ set done_p 0
+ catch "set done_p \[source [file rootname $src].x\]"
+ if { $done_p } {
+ return
+ }
+ }
+
+ set option_list $TORTURE_OPTIONS
+
+ # loop through all the options
+ foreach option $option_list {
+ # torture_compile_xfail is set by the .x script (if present)
+ if [info exists torture_compile_xfail] {
+ setup_xfail $torture_compile_xfail
+ }
+
+ # torture_execute_before_compile is set by the .x script (if present)
+ if [info exists torture_eval_before_compile] {
+ set ignore_me [eval $torture_eval_before_compile]
+ }
+
+ gm2-torture-compile-fail $src "$option $options"
+ }
+}