1# Copyright (C) 2009-2016 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 {^[^$][^\n\r]*[\n\r]+} { 214 send_log "skipping: $expect_out(buffer)" 215 exp_continue 216 } 217 218 timeout { 219 unsupported "$testname" 220 remote_close target 221 return 222 } 223 } 224 225 remote_close target 226 unsupported "$testname" 227 return 228} 229 230# Invoke gdb with a command and pattern-match the output. 231proc gdb_batch_check {command pattern} { 232 set gdb_name $::env(GUALITY_GDB_NAME) 233 set cmd "$gdb_name -nw -nx -quiet -batch -ex \"$command\"" 234 send_log "Spawning: $cmd\n" 235 if [catch { set res [remote_spawn target "$cmd"] } ] { 236 return 0 237 } 238 if { $res < 0 || $res == "" } { 239 return 0 240 } 241 242 remote_expect target [timeout_value] { 243 -re $pattern { 244 return 1 245 } 246 247 -re {^[^\n\r]*[\n\r]+} { 248 verbose "skipping: $expect_out(buffer)" 249 exp_continue 250 } 251 252 timeout { 253 remote_close target 254 return 0 255 } 256 } 257 258 remote_close target 259 return 0 260} 261 262# Check for a new-enough version of gdb. The pretty-printer tests 263# require gdb 7.3, but we don't want to test versions, so instead we 264# check for the python "lookup_global_symbol" method, which is in 7.3 265# but not earlier versions. 266# Return 1 if the version is ok, 0 otherwise. 267proc gdb_version_check {} { 268 return [gdb_batch_check "python print(gdb.lookup_global_symbol)" \ 269 "<built-in function lookup_global_symbol>"] 270} 271 272# Check for a version of gdb which supports xmethod tests. It is done 273# in a manner similar to the check for a version of gdb which supports the 274# pretty-printer tests below. 275proc gdb_version_check_xmethods {} { 276 return [gdb_batch_check \ 277 "python import gdb.xmethod; print(gdb.xmethod.XMethod)" \ 278 "<class 'gdb\\.xmethod\\.XMethod'>"] 279} 280