]>
Commit | Line | Data |
---|---|---|
01bb8ae2 TT |
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 | } |