| # Copyright (C) 2009-2013 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/>. |
| |
| global gdb_tests |
| set gdb_tests {} |
| |
| # Scan a file for markers and fill in the gdb_marker array for that |
| # file. Any error in this script is simply thrown; errors here are |
| # programming errors in the test suite itself and should not be |
| # caught. |
| proc scan_gdb_markers {filename} { |
| global gdb_markers |
| |
| if {[info exists gdb_markers($filename,-)]} { |
| return |
| } |
| |
| set fd [open $filename] |
| set lineno 1 |
| while {! [eof $fd]} { |
| set line [gets $fd] |
| if {[regexp -- "Mark (\[a-zA-Z0-9\]+)" $line ignore marker]} { |
| set gdb_markers($filename,$marker) $lineno |
| } |
| incr lineno |
| } |
| close $fd |
| |
| set gdb_markers($filename,-) {} |
| } |
| |
| # Find a marker in a source file, and return the marker's line number. |
| proc get_line_number {filename marker} { |
| global gdb_markers |
| |
| scan_gdb_markers $filename |
| return $gdb_markers($filename,$marker) |
| } |
| |
| # Make note of a gdb test. A test consists of a variable name and an |
| # expected result. |
| proc note-test {var result} { |
| global gdb_tests |
| |
| lappend gdb_tests $var $result 0 |
| } |
| |
| # A test that uses a regular expression. This is like note-test, but |
| # the result is a regular expression that is matched against the |
| # output. |
| proc regexp-test {var result} { |
| global gdb_tests |
| |
| lappend gdb_tests $var $result 1 |
| } |
| |
| # A test of 'whatis'. This tests a type rather than a variable. |
| proc whatis-test {var result} { |
| global gdb_tests |
| |
| lappend gdb_tests $var $result whatis |
| } |
| |
| # Utility for testing variable values using gdb, invoked via dg-final. |
| # Tests all tests indicated by note-test and regexp-test. |
| # |
| # Argument 0 is the marker on which to put a breakpoint |
| # Argument 2 handles expected failures and the like |
| proc gdb-test { marker {selector {}} } { |
| if { ![isnative] || [is_remote target] } { return } |
| |
| if {[string length $selector] > 0} { |
| switch [dg-process-target $selector] { |
| "S" { } |
| "N" { return } |
| "F" { setup_xfail "*-*-*" } |
| "P" { } |
| } |
| } |
| |
| set do_whatis_tests [gdb_batch_check "python print gdb.type_printers" \ |
| "\\\[\\\]"] |
| if {!$do_whatis_tests} { |
| send_log "skipping 'whatis' tests - gdb too old" |
| } |
| |
| # This assumes that we are three frames down from dg-test, and that |
| # it still stores the filename of the testcase in a local variable "name". |
| # A cleaner solution would require a new DejaGnu release. |
| upvar 2 name testcase |
| upvar 2 prog prog |
| |
| set line [get_line_number $prog $marker] |
| |
| set gdb_name $::env(GUALITY_GDB_NAME) |
| set testname "$testcase" |
| set output_file "[file rootname [file tail $prog]].exe" |
| set cmd_file "[file rootname [file tail $prog]].gdb" |
| |
| global srcdir |
| set pycode [file join $srcdir .. python libstdcxx v6 printers.py] |
| |
| global gdb_tests |
| |
| set fd [open $cmd_file "w"] |
| puts $fd "source $pycode" |
| puts $fd "python register_libstdcxx_printers(None)" |
| puts $fd "break $line" |
| puts $fd "run" |
| |
| set count 0 |
| foreach {var result kind} $gdb_tests { |
| incr count |
| set gdb_var($count) $var |
| set gdb_expected($count) $result |
| if {$kind == "whatis"} { |
| if {$do_whatis_tests} { |
| set gdb_is_type($count) 1 |
| set gdb_command($count) "whatis $var" |
| } else { |
| unsupported "$testname" |
| close $fd |
| return |
| } |
| } else { |
| set gdb_is_type($count) 0 |
| set gdb_is_regexp($count) $kind |
| set gdb_command($count) "print $var" |
| } |
| puts $fd $gdb_command($count) |
| } |
| set gdb_tests {} |
| |
| puts $fd "quit" |
| close $fd |
| |
| send_log "Spawning: $gdb_name -nx -nw -quiet -batch -x $cmd_file ./$output_file\n" |
| set res [remote_spawn target "$gdb_name -nx -nw -quiet -batch -x $cmd_file ./$output_file"] |
| if { $res < 0 || $res == "" } { |
| unsupported "$testname" |
| return |
| } |
| |
| set test_counter 0 |
| remote_expect target [timeout_value] { |
| -re {^(type|\$([0-9]+)) = ([^\n\r]*)[\n\r]+} { |
| send_log "got: $expect_out(buffer)" |
| |
| incr test_counter |
| set first $expect_out(3,string) |
| |
| if {$gdb_is_type($test_counter)} { |
| if {$expect_out(1,string) != "type"} { |
| error "gdb failure" |
| } |
| set match [expr {![string compare $first \ |
| $gdb_expected($test_counter)]}] |
| } elseif {$gdb_is_regexp($test_counter)} { |
| set match [regexp -- $gdb_expected($test_counter) $first] |
| } else { |
| set match [expr {![string compare $first \ |
| $gdb_expected($test_counter)]}] |
| } |
| |
| if {$match} { |
| pass "$testname $gdb_command($test_counter)" |
| } else { |
| fail "$testname $gdb_command($test_counter)" |
| verbose " got =>$first<=" |
| verbose "expected =>$gdb_expected($test_counter)<=" |
| } |
| |
| if {$test_counter == $count} { |
| remote_close target |
| return |
| } else { |
| exp_continue |
| } |
| } |
| |
| -re {Python scripting is not supported in this copy of GDB.[\n\r]+} { |
| unsupported "$testname" |
| remote_close target |
| return |
| } |
| |
| -re {^[^$][^\n\r]*[\n\r]+} { |
| send_log "skipping: $expect_out(buffer)" |
| exp_continue |
| } |
| |
| timeout { |
| unsupported "$testname" |
| remote_close target |
| return |
| } |
| } |
| |
| remote_close target |
| unsupported "$testname" |
| return |
| } |
| |
| # Invoke gdb with a command and pattern-match the output. |
| proc gdb_batch_check {command pattern} { |
| set gdb_name $::env(GUALITY_GDB_NAME) |
| set cmd "$gdb_name -nw -nx -quiet -batch -ex \"$command\"" |
| send_log "Spawning: $cmd\n" |
| if [catch { set res [remote_spawn target "$cmd"] } ] { |
| return 0 |
| } |
| if { $res < 0 || $res == "" } { |
| return 0 |
| } |
| |
| remote_expect target [timeout_value] { |
| -re $pattern { |
| return 1 |
| } |
| |
| -re {^[^\n\r]*[\n\r]+} { |
| verbose "skipping: $expect_out(buffer)" |
| exp_continue |
| } |
| |
| timeout { |
| remote_close target |
| return 0 |
| } |
| } |
| |
| remote_close target |
| return 0 |
| } |
| |
| # Check for a new-enough version of gdb. The pretty-printer tests |
| # require gdb 7.3, but we don't want to test versions, so instead we |
| # check for the python "lookup_global_symbol" method, which is in 7.3 |
| # but not earlier versions. |
| # Return 1 if the version is ok, 0 otherwise. |
| proc gdb_version_check {} { |
| return [gdb_batch_check "python print gdb.lookup_global_symbol" \ |
| "<built-in function lookup_global_symbol>"] |
| } |