1# Copyright (C) 2009-2019 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 17global gdb_tests 18set gdb_tests {} 19 20# Scan a file for markers and fill in the gdb_marker array for that 21# file. Any error in this script is simply thrown; errors here are 22# programming errors in the test suite itself and should not be 23# caught. 24proc scan_gdb_markers {filename} { 25 global gdb_markers 26 27 if {[info exists gdb_markers($filename,-)]} { 28 return 29 } 30 31 set fd [open $filename] 32 set lineno 1 33 while {! [eof $fd]} { 34 set line [gets $fd] 35 if {[regexp -- "Mark (\[a-zA-Z0-9\]+)" $line ignore marker]} { 36 set gdb_markers($filename,$marker) $lineno 37 } 38 incr lineno 39 } 40 close $fd 41 42 set gdb_markers($filename,-) {} 43} 44 45# Find a marker in a source file, and return the marker's line number. 46proc get_line_number {filename marker} { 47 global gdb_markers 48 49 scan_gdb_markers $filename 50 return $gdb_markers($filename,$marker) 51} 52 53# Make note of a gdb test. A test consists of a variable name and an 54# expected result. 55proc note-test {var result} { 56 global gdb_tests 57 58 lappend gdb_tests $var $result 0 59} 60 61# A test that uses a regular expression. This is like note-test, but 62# the result is a regular expression that is matched against the 63# output. 64proc regexp-test {var result} { 65 global gdb_tests 66 67 lappend gdb_tests $var $result 1 68} 69 70# A test of 'whatis'. This tests a type rather than a variable. 71proc whatis-test {var result} { 72 global gdb_tests 73 74 lappend gdb_tests $var $result whatis 75} 76 77# Utility for testing variable values using gdb, invoked via dg-final. 78# Tests all tests indicated by note-test and regexp-test. 79# 80# Argument 0 is the marker on which to put a breakpoint 81# Argument 2 handles expected failures and the like 82proc gdb-test { marker {selector {}} {load_xmethods 0} } { 83 if { ![isnative] || [is_remote target] } { return } 84 85 if {[string length $selector] > 0} { 86 switch [dg-process-target $selector] { 87 "S" { } 88 "N" { return } 89 "F" { setup_xfail "*-*-*" } 90 "P" { } 91 } 92 } 93 94 set do_whatis_tests [gdb_batch_check "python print(gdb.type_printers)" \ 95 "\\\[\\\]"] 96 if {!$do_whatis_tests} { 97 send_log "skipping 'whatis' tests - gdb too old" 98 } 99 100 # This assumes that we are three frames down from dg-test, and that 101 # it still stores the filename of the testcase in a local variable "name". 102 # A cleaner solution would require a new DejaGnu release. 103 upvar 2 name testcase 104 upvar 2 prog prog 105 106 set line [get_line_number $prog $marker] 107 108 set gdb_name $::env(GUALITY_GDB_NAME) 109 set testname "$testcase" 110 set output_file "[file rootname [file tail $prog]].exe" 111 set cmd_file "[file rootname [file tail $prog]].gdb" 112 113 global srcdir 114 set printer_code [file join $srcdir .. python libstdcxx v6 printers.py] 115 set xmethod_code [file join $srcdir .. python libstdcxx v6 xmethods.py] 116 117 global gdb_tests 118 119 set fd [open $cmd_file "w"] 120 # We don't want the system copy of the pretty-printers loaded 121 puts $fd "set auto-load no" 122 # Now that we've disabled auto-load, it's safe to set the target file 123 puts $fd "file ./$output_file" 124 # Load & register *our* copy of the pretty-printers 125 puts $fd "source $printer_code" 126 puts $fd "python register_libstdcxx_printers(None)" 127 if { $load_xmethods } { 128 # Load a& register xmethods. 129 puts $fd "source $xmethod_code" 130 puts $fd "python register_libstdcxx_xmethods(None)" 131 } 132 # And start the program 133 puts $fd "break $line" 134 puts $fd "run" 135 # So we can verify that we're using the right libs ... 136 puts $fd "info share" 137 138 set count 0 139 foreach {var result kind} $gdb_tests { 140 incr count 141 set gdb_var($count) $var 142 set gdb_expected($count) $result 143 if {$kind == "whatis"} { 144 if {$do_whatis_tests} { 145 set gdb_is_type($count) 1 146 set gdb_command($count) "whatis $var" 147 } else { 148 unsupported "$testname" 149 close $fd 150 return 151 } 152 } else { 153 set gdb_is_type($count) 0 154 set gdb_is_regexp($count) $kind 155 set gdb_command($count) "print $var" 156 } 157 puts $fd $gdb_command($count) 158 } 159 set gdb_tests {} 160 161 puts $fd "quit" 162 close $fd 163 164 set res [remote_spawn target "$gdb_name -nx -nw -quiet -batch -x $cmd_file "] 165 if { $res < 0 || $res == "" } { 166 unsupported "$testname" 167 return 168 } 169 170 set test_counter 0 171 remote_expect target [timeout_value] { 172 -re {^(type|\$([0-9]+)) = ([^\n\r]*)[\n\r]+} { 173 send_log "got: $expect_out(buffer)" 174 175 incr test_counter 176 set first $expect_out(3,string) 177 178 if {$gdb_is_type($test_counter)} { 179 if {$expect_out(1,string) != "type"} { 180 error "gdb failure" 181 } 182 set match [expr {![string compare $first \ 183 $gdb_expected($test_counter)]}] 184 } elseif {$gdb_is_regexp($test_counter)} { 185 set match [regexp -- $gdb_expected($test_counter) $first] 186 } else { 187 set match [expr {![string compare $first \ 188 $gdb_expected($test_counter)]}] 189 } 190 191 if {$match} { 192 pass "$testname $gdb_command($test_counter)" 193 } else { 194 fail "$testname $gdb_command($test_counter)" 195 verbose " got =>$first<=" 196 verbose "expected =>$gdb_expected($test_counter)<=" 197 } 198 199 if {$test_counter == $count} { 200 remote_close target 201 return 202 } else { 203 exp_continue 204 } 205 } 206 207 -re {Python scripting is not supported in this copy of GDB.[\n\r]+} { 208 unsupported "$testname" 209 remote_close target 210 return 211 } 212 213 -re {Error while executing Python code.[\n\r]} { 214 fail "$testname" 215 remote_close target 216 return 217 } 218 219 -re {^[^$][^\n\r]*[\n\r]+} { 220 send_log "skipping: $expect_out(buffer)" 221 exp_continue 222 } 223 224 timeout { 225 unsupported "$testname" 226 remote_close target 227 return 228 } 229 } 230 231 remote_close target 232 unsupported "$testname" 233 return 234} 235 236# Invoke gdb with a command and pattern-match the output. 237proc gdb_batch_check {command pattern} { 238 set gdb_name $::env(GUALITY_GDB_NAME) 239 set cmd "$gdb_name -nw -nx -quiet -batch -ex \"$command\"" 240 send_log "Spawning: $cmd\n" 241 if [catch { set res [remote_spawn target "$cmd"] } ] { 242 return 0 243 } 244 if { $res < 0 || $res == "" } { 245 return 0 246 } 247 248 remote_expect target [timeout_value] { 249 -re $pattern { 250 return 1 251 } 252 253 -re {^[^\n\r]*[\n\r]+} { 254 verbose "skipping: $expect_out(buffer)" 255 exp_continue 256 } 257 258 timeout { 259 remote_close target 260 return 0 261 } 262 } 263 264 remote_close target 265 return 0 266} 267 268# Check for a new-enough version of gdb. The pretty-printer tests 269# require gdb 7.3, but we don't want to test versions, so instead we 270# check for the python "lookup_global_symbol" method, which is in 7.3 271# but not earlier versions. 272# Return 1 if the version is ok, 0 otherwise. 273proc gdb_version_check {} { 274 return [gdb_batch_check "python print(gdb.lookup_global_symbol)" \ 275 "<built-in function lookup_global_symbol>"] 276} 277 278# Check for a version of gdb which supports xmethod tests. It is done 279# in a manner similar to the check for a version of gdb which supports the 280# pretty-printer tests below. 281proc gdb_version_check_xmethods {} { 282 return [gdb_batch_check \ 283 "python import gdb.xmethod; print(gdb.xmethod.XMethod)" \ 284 "<class 'gdb\\.xmethod\\.XMethod'>"] 285} 286 287# Like dg-runtest but keep the .exe around. dg-test has an option for 288# this but there is no way to pass it through dg-runtest. 289proc gdb-dg-runtest {args} { 290 global dg-interpreter-batch-mode 291 set saved-dg-interpreter-batch-mode ${dg-interpreter-batch-mode} 292 set dg-interpreter-batch-mode 1 293 294 eval dg-runtest $args 295 296 set dg-interpreter-batch-mode ${saved-dg-interpreter-batch-mode} 297} 298