1# Copyright (C) 2004-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 18load_lib torture-options.exp 19 20# Define gfortran callbacks for dg.exp. 21 22proc gfortran-dg-test { prog do_what extra_tool_flags } { 23 set result \ 24 [gcc-dg-test-1 gfortran_target_compile $prog $do_what $extra_tool_flags] 25 26 set comp_output [lindex $result 0] 27 set output_file [lindex $result 1] 28 29 # gcc's default is to print the caret and source code, but 30 # most test cases implicitly use the flag -fno-diagnostics-show-caret 31 # to disable caret (and source code) printing. 32 # 33 # However, a few test cases override this back to the default by 34 # explicily supplying "-fdiagnostics-show-caret", so that we can have 35 # test coverage for caret/source code printing. 36 # 37 # gfortran error messages with caret-printing look like this: 38 # [name]:[locus]: 39 # 40 # some code 41 # 1 42 # Error: Some error at (1) 43 # or 44 # [name]:[locus]: 45 # 46 # some code 47 # 1 48 # [name]:[locus2]: 49 # 50 # some other code 51 # 2 52 # Error: Some error at (1) and (2) 53 # or 54 # [name]:[locus]: 55 # 56 # some code and some more code 57 # 1 2 58 # Error: Some error at (1) and (2) 59 # 60 # If this is such a test case, skip the rest of this function, so 61 # that the test case can explicitly verify the output that it expects. 62 if {[string first "-fdiagnostics-show-caret" $extra_tool_flags] >= 0} { 63 return [list $comp_output $output_file] 64 } 65 66 # Otherwise, caret-printing is disabled. 67 # gfortran errors with caret-printing disabled look like this: 68 # [name]:[locus]: Error: Some error 69 # or 70 # [name]:[locus]: Error: (1) 71 # [name]:[locus2]: Error: Some error at (1) and (2) 72 # 73 # Where [locus] is either [line] or [line].[column] or 74 # [line].[column]-[column] . 75 # 76 # We collapse these to look like: 77 # [name]:[line]:[column]: Error: Some error at (1) and (2) 78 # or 79 # [name]:[line]:[column]: Error: Some error at (1) and (2) 80 # [name]:[line2]:[column]: Error: Some error at (1) and (2) 81 # 82 # Note that these regexps only make sense in the combinations used below. 83 # Note also that is imperative that we first deal with the form with 84 # two loci. 85 set locus_regexp "(\[^\n\]+:\[0-9\]+)\[\.:\](\[0-9\]+)(-\[0-9\]+)?:\n\n\[^\n\]+\n\[^\n\]+\n" 86 set diag_regexp "(\[^\n\]+)\n" 87 88 # We proceed in steps: 89 90 # 1. We add first a column number if none exists. 91 # (Some Fortran diagnostics have the locus after Warning|Error) 92 set colnum_regexp "(^|\n)(Warning: |Error: )?(\[^:\n\]+:\[0-9\]+):(\[ \n\])" 93 regsub -all $colnum_regexp $comp_output "\\1\\3:0:\\4\\2" comp_output 94 verbose "comput_output0:\n$comp_output" 95 96 # 2. We deal with the form with two different locus lines, 97 set two_loci "(^|\n)$locus_regexp$locus_regexp$diag_regexp" 98 regsub -all $two_loci $comp_output "\\1\\2:\\3: \\8\n\\5\:\\6: \\8\n" comp_output 99 verbose "comput_output1:\n$comp_output" 100 101 set locus_prefix "(\[^:\n\]+:\[0-9\]+:\[0-9\]+: )(Warning: |Error: )" 102 set two_loci2 "(^|\n)$locus_prefix\\(1\\)\n$locus_prefix$diag_regexp" 103 regsub -all $two_loci2 $comp_output "\\1\\2\\3\\6\n\\4\\5\\6\n" comp_output 104 verbose "comput_output2:\n$comp_output" 105 106 # 3. then with the form with only one locus line. 107 set single_locus "(^|\n)$locus_regexp$diag_regexp" 108 regsub -all $single_locus $comp_output "\\1\\2:\\3: \\5\n" comp_output 109 verbose "comput_output3:\n$comp_output" 110 111 # 4. Add a line number if none exists 112 regsub -all "(^|\n)(Warning: |Error: )" $comp_output "\\1:0:0: \\2" comp_output 113 verbose "comput_output4:\n$comp_output" 114 return [list $comp_output $output_file] 115} 116 117proc gfortran-dg-prune { system text } { 118 return [gcc-dg-prune $system $text] 119} 120 121# Utility routines. 122 123# Modified dg-runtest that can cycle through a list of optimization options 124# as c-torture does. 125proc gfortran-dg-runtest { testcases flags default-extra-flags } { 126 global runtests 127 global torture_with_loops 128 129 # Some callers set torture options themselves; don't override those. 130 set existing_torture_options [torture-options-exist] 131 if { $existing_torture_options == 0 } { 132 global DG_TORTURE_OPTIONS 133 torture-init 134 set-torture-options $DG_TORTURE_OPTIONS 135 } 136 dump-torture-options 137 138 foreach test $testcases { 139 # If we're only testing specific files and this isn't one of 140 # them, skip it. 141 if ![runtest_file_p $runtests $test] { 142 continue 143 } 144 145 # look if this is dg-do-run test, in which case 146 # we cycle through the option list, otherwise we don't 147 if [expr [search_for $test "dg-do run"]] { 148 set option_list $torture_with_loops 149 } else { 150 set option_list [list { -O } ] 151 } 152 153 set nshort [file tail [file dirname $test]]/[file tail $test] 154 list-module-names $test 155 156 foreach flags_t $option_list { 157 verbose "Testing $nshort, $flags $flags_t" 1 158 dg-test $test "$flags $flags_t" ${default-extra-flags} 159 cleanup-modules "" 160 } 161 } 162 163 if { $existing_torture_options == 0 } { 164 torture-finish 165 } 166} 167 168proc gfortran-dg-debug-runtest { target_compile trivial opt_opts testcases } { 169 global srcdir subdir DEBUG_TORTURE_OPTIONS 170 171 if ![info exists DEBUG_TORTURE_OPTIONS] { 172 set DEBUG_TORTURE_OPTIONS "" 173 set type_list [list "-gstabs" "-gstabs+" "-gxcoff" "-gxcoff+" "-gdwarf-2" ] 174 foreach type $type_list { 175 set comp_output [$target_compile \ 176 "$srcdir/$subdir/$trivial" "trivial.S" assembly \ 177 "additional_flags=$type"] 178 if { [string match "exit status *" $comp_output] } { 179 continue 180 } 181 if { [string match \ 182 "* target system does not support the * debug format*" \ 183 $comp_output] 184 } { 185 continue 186 } 187 remove-build-file "trivial.S" 188 foreach level {1 "" 3} { 189 if { ($type == "-gdwarf-2") && ($level != "") } { 190 lappend DEBUG_TORTURE_OPTIONS [list "${type}" "-g${level}"] 191 foreach opt $opt_opts { 192 lappend DEBUG_TORTURE_OPTIONS \ 193 [list "${type}" "-g${level}" "$opt" ] 194 } 195 } else { 196 lappend DEBUG_TORTURE_OPTIONS [list "${type}${level}"] 197 foreach opt $opt_opts { 198 lappend DEBUG_TORTURE_OPTIONS \ 199 [list "${type}${level}" "$opt" ] 200 } 201 } 202 } 203 } 204 } 205 206 verbose -log "Using options $DEBUG_TORTURE_OPTIONS" 207 208 global runtests 209 210 foreach test $testcases { 211 # If we're only testing specific files and this isn't one of 212 # them, skip it. 213 if ![runtest_file_p $runtests $test] { 214 continue 215 } 216 217 set nshort [file tail [file dirname $test]]/[file tail $test] 218 list-module-names $test 219 220 foreach flags $DEBUG_TORTURE_OPTIONS { 221 set doit 1 222 # gcc-specific checking removed here 223 224 if { $doit } { 225 verbose -log "Testing $nshort, $flags" 1 226 dg-test $test $flags "" 227 cleanup-modules "" 228 } 229 } 230 } 231} 232