1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
|
# Copyright (C) 2009, 2011, 2012 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>"]
}
|