libstdc++-v3/testsuite/lib/gdb-test.exp

   1 #   Copyright (C) 2009, 2011 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
  17 global gdb_tests
  18 set 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.
  24 proc 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.
  46 proc 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.
  55 proc note-test {var result} {
  56     global gdb_tests
  57
  58     lappend gdb_tests $var $result
  59 }
  60
  61 # Utility for testing variable values using gdb, invoked via dg-final.
  62 # Tests all tests indicated by note-test.
  63 #
  64 # Argument 0 is the marker on which to put a breakpoint
  65 # Argument 2 handles expected failures and the like
  66 proc gdb-test { marker {selector {}} } {
  67     if { ![isnative] || [is_remote target] } { return }
  68
  69     if {[string length $selector] > 0} {
  70         switch [dg-process-target $selector] {
  71             "S" { }
  72             "N" { return }
  73             "F" { setup_xfail "*-*-*" }
  74             "P" { }
  75         }
  76     }
  77
  78     # This assumes that we are three frames down from dg-test, and that
  79     # it still stores the filename of the testcase in a local variable "name".
  80     # A cleaner solution would require a new DejaGnu release.
  81     upvar 2 name testcase
  82     upvar 2 prog prog
  83
  84     set line [get_line_number $prog $marker]
  85
  86     set gdb_name $::env(GUALITY_GDB_NAME)
  87     set testname "$testcase"
  88     set output_file "[file rootname [file tail $prog]].exe"
  89     set cmd_file "[file rootname [file tail $prog]].gdb"
  90
  91     global srcdir
  92     set pycode [file join $srcdir .. python libstdcxx v6 printers.py]
  93
  94     global gdb_tests
  95
  96     set fd [open $cmd_file "w"]
  97     puts $fd "source $pycode"
  98     puts $fd "python register_libstdcxx_printers(None)"
  99     puts $fd "break $line"
 100     puts $fd "run"
 101
 102     set count 0
 103     foreach {var result} $gdb_tests {
 104         puts $fd "print $var"
 105         incr count
 106         set gdb_var($count) $var
 107         set gdb_expected($count) $result
 108     }
 109     set gdb_tests {}
 110
 111     puts $fd "quit"
 112     close $fd
 113
 114     send_log "Spawning: $gdb_name -nx -nw -quiet -batch -x $cmd_file ./$output_file\n"
 115     set res [remote_spawn target "$gdb_name -nx -nw -quiet -batch -x $cmd_file ./$output_file"]
 116     if { $res < 0 || $res == "" } {
 117         unsupported "$testname"
 118         return
 119     }
 120
 121     remote_expect target [timeout_value] {
 122         -re {^\$([0-9]+) = ([^\n\r]*)[\n\r]+} {
 123             set num $expect_out(1,string)
 124             set first $expect_out(2,string)
 125             if { ![string compare $first $gdb_expected($num)] } {
 126                 pass "$testname print $gdb_var($num)"
 127             } else {
 128                 fail "$testname print $gdb_var($num)"
 129                 verbose "     got =>$first<="
 130                 verbose "expected =>$gdb_expected($num)<="
 131             }
 132
 133             if {$num == $count} {
 134                 remote_close target
 135                 return
 136             } else {
 137                 exp_continue
 138             }
 139         }
 140
 141         -re {Python scripting is not supported in this copy of GDB.[\n\r]+} {
 142             unsupported "$testname"
 143             remote_close target
 144             return
 145         }
 146
 147         -re {^[^$][^\n\r]*[\n\r]+} {
 148             verbose "skipping: $expect_out(buffer)"
 149             exp_continue
 150         }
 151
 152         timeout {
 153             unsupported "$testname"
 154             remote_close target
 155             return
 156         }
 157     }
 158
 159     remote_close target
 160     unsupported "$testname"
 161     return
 162 }
 163
 164 # Check for a new-enough version of gdb.  The pretty-printer tests
 165 # require gdb 7.3, but we don't want to test versions, so instead we
 166 # check for the python "lookup_global_symbol" method, which is in 7.3
 167 # but not earlier versions.
 168 # Return 1 if the version is ok, 0 otherwise.
 169 proc gdb_version_check {} {
 170     global gdb_version
 171
 172     set gdb_name $::env(GUALITY_GDB_NAME)
 173     set cmd "$gdb_name -nw -nx -quiet -batch -ex \"python print gdb.lookup_global_symbol\""
 174     send_log "Spawning: $cmd\n"
 175     set res [remote_spawn target "$cmd"]
 176     if { $res < 0 || $res == "" } {
 177         return 0
 178     }
 179
 180     remote_expect target [timeout_value] {
 181         -re "<built-in function lookup_global_symbol>" {
 182             return 1
 183         }
 184
 185         -re {^[^\n\r]*[\n\r]+} {
 186             verbose "skipping: $expect_out(buffer)"
 187             exp_continue
 188         }
 189
 190         timeout {
 191             remote_close target
 192             return 0
 193         }
 194     }
 195
 196     remote_close target
 197     return 0
 198 }