1# Copyright (C) 2006-2021 Free Software Foundation, Inc. 2 3# This program is free software; you can redistribute it and/or modify 4# it under the terms of the GNU General Public License as published by 5# the Free Software Foundation; either version 3 of the License, or 6# (at your option) any later version. 7# 8# This program is distributed in the hope that it will be useful, 9# but WITHOUT ANY WARRANTY; without even the implied warranty of 10# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11# GNU General Public License for more details. 12# 13# You should have received a copy of the GNU General Public License 14# along with GCC; see the file COPYING3. If not see 15# <http://www.gnu.org/licenses/>. 16 17load_lib gcc-dg.exp 18 19# Remove VALUE from LIST_VARIABLE. 20proc lremove {list_variable value} { 21 upvar 1 $list_variable var 22 set idx [lsearch -exact $var $value] 23 set var [lreplace $var $idx $idx] 24} 25 26# Define gcc callbacks for dg.exp. 27 28proc gnat-dg-test { prog do_what extra_tool_flags } { 29 if { $do_what == "compile" } { 30 lappend extra_tool_flags "-c" 31 lappend extra_tool_flags "-u" 32 } 33 set result [gcc-dg-test-1 gnat_target_compile $prog $do_what $extra_tool_flags] 34 35 # Remove additional output files apart from $output_file, which may be 36 # needed by dg-final. 37 set output_file [lindex $result 1] 38 set basename [file rootname $output_file] 39 set clean_result [remote_exec host [find_gnatclean] "-c -q -n $basename"] 40 if { [lindex $clean_result 0] != -1 } { 41 set clean_files [lindex $clean_result 1] 42 # Purge NL from clean_files. 43 regsub -all "\[\r\n\]+" $clean_files " " clean_files 44 # Remove ./ so lremove works. 45 regsub -all "\./" $clean_files "" clean_files 46 lremove clean_files $output_file 47 eval remote_file host delete $clean_files 48 } 49 50 return $result 51} 52 53proc gnat-dg-prune { system text } { 54 global additional_prunes 55 56 lappend additional_prunes "gnatmake" 57 lappend additional_prunes "compilation abandoned" 58 lappend additional_prunes "fatal error: maximum errors reached" 59 lappend additional_prunes "linker input file" 60 61 return [gcc-dg-prune $system $text] 62} 63 64# Utility routines. 65 66# 67# gnat_load -- wrapper around default gnat_load to declare tasking tests 68# unsupported on platforms that lack such support 69# 70 71if { [info procs gnat_load] != [list] \ 72 && [info procs prev_gnat_load] == [list] } { 73 rename gnat_load prev_gnat_load 74 75 proc gnat_load { program args } { 76 upvar name testcase 77 78 set result [eval [list prev_gnat_load $program] $args] 79 set output [lindex $result 1] 80 if { [regexp "tasking not implemented" $output] } { 81 return [list "unsupported" $output] 82 } 83 return $result 84 } 85} 86 87# Local Variables: 88# tcl-indent-level:4 89# End: 90