]>
Commit | Line | Data |
---|---|---|
3efe2bf7 | 1 | # Copyright (C) 2009, 2011, 2012 Free Software Foundation, Inc. |
01bb8ae2 TT |
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 | ||
3efe2bf7 TT |
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. | |
64 | proc regexp-test {var result} { | |
65 | global gdb_tests | |
66 | ||
67 | lappend gdb_tests $var $result 1 | |
01bb8ae2 TT |
68 | } |
69 | ||
50605a7f TT |
70 | # A test of 'whatis'. This tests a type rather than a variable. |
71 | proc whatis-test {var result} { | |
72 | global gdb_tests | |
73 | ||
74 | lappend gdb_tests $var $result whatis | |
75 | } | |
76 | ||
01bb8ae2 | 77 | # Utility for testing variable values using gdb, invoked via dg-final. |
3efe2bf7 | 78 | # Tests all tests indicated by note-test and regexp-test. |
01bb8ae2 TT |
79 | # |
80 | # Argument 0 is the marker on which to put a breakpoint | |
81 | # Argument 2 handles expected failures and the like | |
82 | proc gdb-test { marker {selector {}} } { | |
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 | ||
50605a7f TT |
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 | ||
01bb8ae2 TT |
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 pycode [file join $srcdir .. python libstdcxx v6 printers.py] | |
115 | ||
116 | global gdb_tests | |
117 | ||
118 | set fd [open $cmd_file "w"] | |
119 | puts $fd "source $pycode" | |
120 | puts $fd "python register_libstdcxx_printers(None)" | |
121 | puts $fd "break $line" | |
122 | puts $fd "run" | |
123 | ||
124 | set count 0 | |
50605a7f | 125 | foreach {var result kind} $gdb_tests { |
01bb8ae2 TT |
126 | incr count |
127 | set gdb_var($count) $var | |
128 | set gdb_expected($count) $result | |
50605a7f TT |
129 | if {$kind == "whatis"} { |
130 | if {$do_whatis_tests} { | |
131 | set gdb_is_type($count) 1 | |
132 | set gdb_command($count) "whatis $var" | |
133 | } else { | |
134 | unsupported "$testname" | |
135 | close $fd | |
136 | return | |
137 | } | |
138 | } else { | |
139 | set gdb_is_type($count) 0 | |
140 | set gdb_is_regexp($count) $kind | |
141 | set gdb_command($count) "print $var" | |
142 | } | |
143 | puts $fd $gdb_command($count) | |
01bb8ae2 TT |
144 | } |
145 | set gdb_tests {} | |
146 | ||
147 | puts $fd "quit" | |
148 | close $fd | |
149 | ||
150 | send_log "Spawning: $gdb_name -nx -nw -quiet -batch -x $cmd_file ./$output_file\n" | |
151 | set res [remote_spawn target "$gdb_name -nx -nw -quiet -batch -x $cmd_file ./$output_file"] | |
152 | if { $res < 0 || $res == "" } { | |
153 | unsupported "$testname" | |
154 | return | |
155 | } | |
156 | ||
50605a7f | 157 | set test_counter 0 |
01bb8ae2 | 158 | remote_expect target [timeout_value] { |
50605a7f | 159 | -re {^(type|\$([0-9]+)) = ([^\n\r]*)[\n\r]+} { |
3efe2bf7 TT |
160 | send_log "got: $expect_out(buffer)" |
161 | ||
50605a7f TT |
162 | incr test_counter |
163 | set first $expect_out(3,string) | |
164 | ||
165 | if {$gdb_is_type($test_counter)} { | |
166 | if {$expect_out(1,string) != "type"} { | |
167 | error "gdb failure" | |
168 | } | |
169 | set match [expr {![string compare $first \ | |
170 | $gdb_expected($test_counter)]}] | |
171 | } elseif {$gdb_is_regexp($test_counter)} { | |
172 | set match [regexp -- $gdb_expected($test_counter) $first] | |
3efe2bf7 | 173 | } else { |
50605a7f TT |
174 | set match [expr {![string compare $first \ |
175 | $gdb_expected($test_counter)]}] | |
3efe2bf7 TT |
176 | } |
177 | ||
178 | if {$match} { | |
50605a7f | 179 | pass "$testname $gdb_command($test_counter)" |
01bb8ae2 | 180 | } else { |
50605a7f | 181 | fail "$testname $gdb_command($test_counter)" |
01bb8ae2 | 182 | verbose " got =>$first<=" |
50605a7f | 183 | verbose "expected =>$gdb_expected($test_counter)<=" |
01bb8ae2 TT |
184 | } |
185 | ||
50605a7f | 186 | if {$test_counter == $count} { |
01bb8ae2 TT |
187 | remote_close target |
188 | return | |
189 | } else { | |
190 | exp_continue | |
191 | } | |
192 | } | |
193 | ||
194 | -re {Python scripting is not supported in this copy of GDB.[\n\r]+} { | |
195 | unsupported "$testname" | |
196 | remote_close target | |
197 | return | |
198 | } | |
199 | ||
200 | -re {^[^$][^\n\r]*[\n\r]+} { | |
3efe2bf7 | 201 | send_log "skipping: $expect_out(buffer)" |
01bb8ae2 TT |
202 | exp_continue |
203 | } | |
204 | ||
205 | timeout { | |
206 | unsupported "$testname" | |
207 | remote_close target | |
208 | return | |
209 | } | |
210 | } | |
211 | ||
212 | remote_close target | |
213 | unsupported "$testname" | |
214 | return | |
215 | } | |
216 | ||
50605a7f TT |
217 | # Invoke gdb with a command and pattern-match the output. |
218 | proc gdb_batch_check {command pattern} { | |
01bb8ae2 | 219 | set gdb_name $::env(GUALITY_GDB_NAME) |
50605a7f | 220 | set cmd "$gdb_name -nw -nx -quiet -batch -ex \"$command\"" |
01bb8ae2 TT |
221 | send_log "Spawning: $cmd\n" |
222 | set res [remote_spawn target "$cmd"] | |
223 | if { $res < 0 || $res == "" } { | |
224 | return 0 | |
225 | } | |
226 | ||
227 | remote_expect target [timeout_value] { | |
50605a7f | 228 | -re $pattern { |
01bb8ae2 TT |
229 | return 1 |
230 | } | |
231 | ||
232 | -re {^[^\n\r]*[\n\r]+} { | |
233 | verbose "skipping: $expect_out(buffer)" | |
234 | exp_continue | |
235 | } | |
236 | ||
237 | timeout { | |
238 | remote_close target | |
239 | return 0 | |
240 | } | |
241 | } | |
242 | ||
243 | remote_close target | |
244 | return 0 | |
245 | } | |
50605a7f TT |
246 | |
247 | # Check for a new-enough version of gdb. The pretty-printer tests | |
248 | # require gdb 7.3, but we don't want to test versions, so instead we | |
249 | # check for the python "lookup_global_symbol" method, which is in 7.3 | |
250 | # but not earlier versions. | |
251 | # Return 1 if the version is ok, 0 otherwise. | |
252 | proc gdb_version_check {} { | |
253 | return [gdb_batch_check "python print gdb.lookup_global_symbol" \ | |
254 | "<built-in function lookup_global_symbol>"] | |
255 | } |