Commit | Line | Data |
---|---|---|
fa5864d5 | 1 | # Copyright (C) 1992, 1994, 1995, 1997 Free Software Foundation, Inc. |
19fa4a0a MW |
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 2 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 this program; if not, write to the Free Software | |
fa5864d5 | 15 | # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
19fa4a0a MW |
16 | |
17 | # Please email any bugs, comments, and/or additions to this file to: | |
c79f61db | 18 | # bug-gdb@prep.ai.mit.edu |
19fa4a0a MW |
19 | |
20 | # This file was written by Fred Fish. (fnf@cygnus.com) | |
21 | ||
22 | # Generic gdb subroutines that should work for any target. If these | |
23 | # need to be modified for any target, it can be done with a variable | |
24 | # or by passing arguments. | |
25 | ||
4771fe15 JL |
26 | load_lib libgloss.exp |
27 | ||
9bcc6c3f | 28 | global GDB |
4771fe15 JL |
29 | global CHILL_LIB |
30 | global CHILL_RT0 | |
31 | ||
4771fe15 JL |
32 | if ![info exists CHILL_LIB] { |
33 | set CHILL_LIB [findfile $base_dir/../../gcc/ch/runtime/libchill.a "$base_dir/../../gcc/ch/runtime/libchill.a" [transform -lchill]] | |
4771fe15 | 34 | } |
a26fa899 | 35 | verbose "using CHILL_LIB = $CHILL_LIB" 2 |
4771fe15 JL |
36 | if ![info exists CHILL_RT0] { |
37 | set CHILL_RT0 [findfile $base_dir/../../gcc/ch/runtime/chillrt0.o "$base_dir/../../gcc/ch/runtime/chillrt0.o" ""] | |
4771fe15 | 38 | } |
a26fa899 | 39 | verbose "using CHILL_RT0 = $CHILL_RT0" 2 |
4771fe15 | 40 | |
787f6220 BM |
41 | if ![info exists GDB] { |
42 | if ![is_remote host] { | |
43 | set GDB [findfile $base_dir/../../gdb/gdb "$base_dir/../../gdb/gdb" [transform gdb]] | |
44 | } else { | |
ddb594ac | 45 | set GDB [transform gdb]; |
f7ef65ff | 46 | } |
9bcc6c3f | 47 | } |
a26fa899 | 48 | verbose "using GDB = $GDB" 2 |
4771fe15 | 49 | |
9bcc6c3f | 50 | global GDBFLAGS |
787f6220 | 51 | if ![info exists GDBFLAGS] { |
65424cda | 52 | set GDBFLAGS "-nx" |
85174909 | 53 | } |
a26fa899 | 54 | verbose "using GDBFLAGS = $GDBFLAGS" 2 |
85174909 | 55 | |
8c7ab5da JK |
56 | # The variable prompt is a regexp which matches the gdb prompt. Set it if it |
57 | # is not already set. | |
85fbaa74 | 58 | global gdb_prompt |
90fba5fa | 59 | if ![info exists prompt] then { |
85fbaa74 | 60 | set gdb_prompt "\[(\]gdb\[)\]" |
120edc2f KH |
61 | } |
62 | ||
5019a275 | 63 | # |
f34c8766 | 64 | # gdb_version -- extract and print the version number of GDB |
5019a275 RS |
65 | # |
66 | proc default_gdb_version {} { | |
67 | global GDB | |
68 | global GDBFLAGS | |
85fbaa74 | 69 | global gdb_prompt |
787f6220 BM |
70 | set fileid [open "gdb_cmd" w]; |
71 | puts $fileid "q"; | |
72 | close $fileid; | |
73 | set cmdfile [remote_download host "gdb_cmd"]; | |
74 | set output [remote_exec host "$GDB -nw --command $cmdfile"] | |
75 | remote_file build delete "gdb_cmd"; | |
76 | remote_file host delete "$cmdfile"; | |
77 | set tmp [lindex $output 1]; | |
78 | set version "" | |
79 | regexp " \[0-9\]\[^ \t\n\r\]+" "$tmp" version | |
80 | if ![is_remote host] { | |
81 | clone_output "[which $GDB] version $version $GDBFLAGS\n" | |
5019a275 | 82 | } else { |
787f6220 | 83 | clone_output "$GDB on remote host version $version $GDBFLAGS\n" |
5019a275 RS |
84 | } |
85 | } | |
86 | ||
787f6220 BM |
87 | proc gdb_version { } { |
88 | return [default_gdb_version]; | |
89 | } | |
90 | ||
19fa4a0a MW |
91 | # |
92 | # gdb_unload -- unload a file if one is loaded | |
93 | # | |
94 | ||
95 | proc gdb_unload {} { | |
96 | global verbose | |
97 | global GDB | |
85fbaa74 | 98 | global gdb_prompt |
787f6220 | 99 | send_gdb "file\n" |
40ac1624 | 100 | gdb_expect { |
fb07c696 BM |
101 | -re "No exec file now\[^\r\n\]*\[\r\n\]" { exp_continue } |
102 | -re "No symbol file now\[^\r\n\]*\[\r\n\]" { exp_continue } | |
9bcc6c3f | 103 | -re "A program is being debugged already..*Kill it.*y or n. $"\ |
787f6220 | 104 | { send_gdb "y\n" |
85174909 | 105 | verbose "\t\tKilling previous program being debugged" |
9bcc6c3f | 106 | exp_continue |
19fa4a0a | 107 | } |
fb07c696 | 108 | -re "Discard symbol table from .*y or n.*$" { |
787f6220 | 109 | send_gdb "y\n" |
9bcc6c3f | 110 | exp_continue |
19fa4a0a | 111 | } |
85fbaa74 | 112 | -re "$gdb_prompt $" {} |
19fa4a0a | 113 | timeout { |
85174909 | 114 | perror "couldn't unload file in $GDB (timed out)." |
c79f61db | 115 | return -1 |
19fa4a0a MW |
116 | } |
117 | } | |
118 | } | |
119 | ||
120 | # Many of the tests depend on setting breakpoints at various places and | |
121 | # running until that breakpoint is reached. At times, we want to start | |
122 | # with a clean-slate with respect to breakpoints, so this utility proc | |
123 | # lets us do this without duplicating this code everywhere. | |
124 | # | |
125 | ||
126 | proc delete_breakpoints {} { | |
85fbaa74 | 127 | global gdb_prompt |
19fa4a0a | 128 | |
787f6220 | 129 | send_gdb "delete breakpoints\n" |
40ac1624 | 130 | gdb_expect { |
fb07c696 | 131 | -re "Delete all breakpoints.*y or n.*$" { |
787f6220 | 132 | send_gdb "y\n"; |
9bcc6c3f | 133 | exp_continue |
19fa4a0a | 134 | } |
fb07c696 | 135 | -re "$gdb_prompt $" { # This happens if there were no breakpoints |
31711c69 | 136 | } |
40ac1624 | 137 | timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return } |
19fa4a0a | 138 | } |
787f6220 | 139 | send_gdb "info breakpoints\n" |
40ac1624 BM |
140 | gdb_expect { |
141 | -re "No breakpoints or watchpoints..*$gdb_prompt $" {} | |
fb07c696 | 142 | -re "$gdb_prompt $" { perror "breakpoints not deleted" ; return } |
40ac1624 | 143 | -re "Delete all breakpoints.*or n.*$" { |
787f6220 BM |
144 | send_gdb "y\n"; |
145 | exp_continue | |
146 | } | |
40ac1624 | 147 | timeout { perror "info breakpoints (timeout)" ; return } |
19fa4a0a MW |
148 | } |
149 | } | |
150 | ||
151 | ||
152 | # | |
70bcd4bc | 153 | # Generic run command. |
809943cf | 154 | # |
70bcd4bc SS |
155 | # The second pattern below matches up to the first newline *only*. |
156 | # Using ``.*$'' could swallow up output that we attempt to match | |
157 | # elsewhere. | |
809943cf | 158 | # |
787f6220 | 159 | proc gdb_run_cmd {args} { |
85fbaa74 | 160 | global gdb_prompt |
787f6220 | 161 | |
ae7872ef BM |
162 | if [target_info exists gdb_init_command] { |
163 | send_gdb "[target_info gdb_init_command]\n"; | |
164 | gdb_expect { | |
fb07c696 | 165 | -re "$gdb_prompt $" { } |
ae7872ef BM |
166 | default { |
167 | perror "gdb_init_command for target failed"; | |
168 | return; | |
169 | } | |
170 | } | |
171 | } | |
065924f7 | 172 | |
787f6220 | 173 | if [target_info exists use_gdb_stub] { |
eb659148 BM |
174 | if [target_info exists gdb,start_symbol] { |
175 | set start [target_info gdb,start_symbol]; | |
176 | } else { | |
177 | set start "start"; | |
178 | } | |
179 | send_gdb "jump *$start\n" | |
40ac1624 | 180 | gdb_expect { |
b6f32a5b BM |
181 | -re "Continuing at \[^\r\n\]*\[\r\n\]" { |
182 | if ![target_info exists gdb_stub] { | |
183 | return; | |
184 | } | |
185 | } | |
eb659148 BM |
186 | -re "No symbol \"start\" in current.*$gdb_prompt $" { |
187 | send_gdb "jump *_start\n"; | |
188 | exp_continue; | |
189 | } | |
190 | -re "No symbol \"_start\" in current.*$gdb_prompt $" { | |
191 | perror "Can't find start symbol to run in gdb_run"; | |
192 | return; | |
193 | } | |
065924f7 | 194 | -re "Line.* Jump anyway.*y or n. $" { |
787f6220 | 195 | send_gdb "y\n" |
b6f32a5b | 196 | exp_continue; |
065924f7 | 197 | } |
85fbaa74 BM |
198 | -re "No symbol.*context.*$gdb_prompt $" {} |
199 | -re "The program is not being run.*$gdb_prompt $" { | |
787f6220 | 200 | gdb_load ""; |
77f3ac77 BM |
201 | send_gdb "jump *$start\n"; |
202 | exp_continue; | |
787f6220 | 203 | } |
065924f7 KH |
204 | timeout { perror "Jump to start() failed (timeout)"; return } |
205 | } | |
b6f32a5b | 206 | if [target_info exists gdb_stub] { |
40ac1624 | 207 | gdb_expect { |
fb07c696 | 208 | -re "$gdb_prompt $" { |
b6f32a5b BM |
209 | send_gdb "continue\n" |
210 | } | |
211 | } | |
212 | } | |
065924f7 KH |
213 | return |
214 | } | |
787f6220 BM |
215 | send_gdb "run $args\n" |
216 | # This doesn't work quite right yet. | |
40ac1624 | 217 | gdb_expect { |
809943cf | 218 | -re "The program .* has been started already.*y or n. $" { |
787f6220 | 219 | send_gdb "y\n" |
809943cf C |
220 | exp_continue |
221 | } | |
ae7872ef | 222 | -re "Starting program: \[^\r\n\]*" {} |
809943cf C |
223 | } |
224 | } | |
225 | ||
787f6220 | 226 | proc gdb_breakpoint { function } { |
85fbaa74 | 227 | global gdb_prompt |
787f6220 | 228 | global decimal |
787f6220 BM |
229 | |
230 | send_gdb "break $function\n" | |
231 | # The first two regexps are what we get with -g, the third is without -g. | |
40ac1624 | 232 | gdb_expect { |
85fbaa74 BM |
233 | -re "Breakpoint \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {} |
234 | -re "Breakpoint \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {} | |
235 | -re "Breakpoint \[0-9\]* at .*$gdb_prompt $" {} | |
236 | -re "$gdb_prompt $" { fail "setting breakpoint at $function" ; return 0 } | |
787f6220 BM |
237 | timeout { fail "setting breakpoint at $function (timeout)" ; return 0 } |
238 | } | |
239 | return 1; | |
240 | } | |
809943cf | 241 | |
19fa4a0a MW |
242 | # Set breakpoint at function and run gdb until it breaks there. |
243 | # Since this is the only breakpoint that will be set, if it stops | |
244 | # at a breakpoint, we will assume it is the one we want. We can't | |
245 | # just compare to "function" because it might be a fully qualified, | |
246 | # single quoted C++ function specifier. | |
19fa4a0a MW |
247 | |
248 | proc runto { function } { | |
85fbaa74 | 249 | global gdb_prompt |
19fa4a0a | 250 | global decimal |
19fa4a0a | 251 | |
787f6220 BM |
252 | delete_breakpoints |
253 | ||
254 | if ![gdb_breakpoint $function] { | |
255 | return 0; | |
19fa4a0a MW |
256 | } |
257 | ||
4f2ec2ee C |
258 | gdb_run_cmd |
259 | ||
c79f61db RS |
260 | # the "at foo.c:36" output we get with -g. |
261 | # the "in func" output we get without -g. | |
40ac1624 | 262 | gdb_expect { |
85fbaa74 | 263 | -re "Break.* at .*:$decimal.*$gdb_prompt $" { |
4f2ec2ee | 264 | return 1 |
412c988b | 265 | } |
b6f32a5b | 266 | -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in .*$gdb_prompt $" { |
c79f61db RS |
267 | return 1 |
268 | } | |
85fbaa74 | 269 | -re "$gdb_prompt $" { |
787f6220 | 270 | fail "running to $function in runto" |
4f2ec2ee C |
271 | return 0 |
272 | } | |
273 | timeout { | |
787f6220 | 274 | fail "running to $function in runto (timeout)" |
4f2ec2ee C |
275 | return 0 |
276 | } | |
19fa4a0a | 277 | } |
1a7dadf9 | 278 | return 1 |
19fa4a0a MW |
279 | } |
280 | ||
120edc2f | 281 | # |
787f6220 BM |
282 | # runto_main -- ask gdb to run until we hit a breakpoint at main. |
283 | # The case where the target uses stubs has to be handled | |
284 | # specially--if it uses stubs, assuming we hit | |
285 | # breakpoint() and just step out of the function. | |
120edc2f KH |
286 | # |
287 | proc runto_main {} { | |
85fbaa74 | 288 | global gdb_prompt |
120edc2f | 289 | global decimal |
120edc2f | 290 | |
787f6220 | 291 | if ![target_info exists gdb_stub] { |
f646eef4 | 292 | return [runto main] |
120edc2f KH |
293 | } |
294 | ||
787f6220 | 295 | delete_breakpoints |
120edc2f | 296 | |
787f6220 | 297 | send_gdb "step\n" |
120edc2f | 298 | # if use stubs step out of the breakpoint() function. |
40ac1624 | 299 | gdb_expect { |
85fbaa74 BM |
300 | -re "main.* at .*$gdb_prompt $" {} |
301 | -re "_start.*$gdb_prompt $" {} | |
120edc2f KH |
302 | timeout { fail "single step at breakpoint() (timeout)" ; return 0 } |
303 | } | |
3c23a941 | 304 | return 1 |
120edc2f KH |
305 | } |
306 | ||
19fa4a0a | 307 | # |
787f6220 | 308 | # gdb_test -- send_gdb a command to gdb and test the result. |
19fa4a0a MW |
309 | # Takes three parameters. |
310 | # Parameters: | |
787f6220 BM |
311 | # First one is the command to execute. If this is the null string |
312 | # then no command is sent. | |
5fac6a39 FF |
313 | # Second one is the pattern to match for a PASS, and must NOT include |
314 | # the \r\n sequence immediately before the gdb prompt. | |
19fa4a0a | 315 | # Third one is an optional message to be printed. If this |
787f6220 BM |
316 | # a null string "", then the pass/fail messages use the command |
317 | # string as the message. | |
19fa4a0a MW |
318 | # Returns: |
319 | # 1 if the test failed, | |
320 | # 0 if the test passes, | |
321 | # -1 if there was an internal error. | |
322 | # | |
323 | proc gdb_test { args } { | |
324 | global verbose | |
85fbaa74 | 325 | global gdb_prompt |
19fa4a0a | 326 | global GDB |
f646eef4 | 327 | global expect_out |
4771fe15 | 328 | upvar timeout timeout |
19fa4a0a | 329 | |
787f6220 | 330 | if [llength $args]>2 then { |
19fa4a0a MW |
331 | set message [lindex $args 2] |
332 | } else { | |
333 | set message [lindex $args 0] | |
334 | } | |
335 | set command [lindex $args 0] | |
336 | set pattern [lindex $args 1] | |
337 | ||
787f6220 BM |
338 | if [llength $args]==5 { |
339 | set question_string [lindex $args 3]; | |
340 | set response_string [lindex $args 4]; | |
341 | } else { | |
342 | set question_string "^FOOBAR$" | |
343 | } | |
344 | ||
19fa4a0a MW |
345 | if $verbose>2 then { |
346 | send_user "Sending \"$command\" to gdb\n" | |
347 | send_user "Looking to match \"$pattern\"\n" | |
348 | send_user "Message is \"$message\"\n" | |
349 | } | |
350 | ||
351 | set result -1 | |
70bcd4bc | 352 | if ![string match $command ""] { |
6a590607 | 353 | if { [send_gdb "$command\n"] != "" } { |
ae7872ef BM |
354 | global suppress_flag; |
355 | ||
356 | if { ! $suppress_flag } { | |
357 | perror "Couldn't send $command to GDB."; | |
358 | } | |
3c0af8a0 | 359 | fail "$message"; |
6a590607 BM |
360 | return $result; |
361 | } | |
19fa4a0a MW |
362 | } |
363 | ||
40ac1624 | 364 | gdb_expect { |
fb07c696 | 365 | -re "Ending remote debugging.*$gdb_prompt$" { |
19fa4a0a MW |
366 | if ![isnative] then { |
367 | warning "Can`t communicate to remote target." | |
368 | } | |
369 | gdb_exit | |
370 | gdb_start | |
371 | set result -1 | |
372 | } | |
40ac1624 | 373 | -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" { |
19fa4a0a MW |
374 | if ![string match "" $message] then { |
375 | pass "$message" | |
376 | } | |
377 | set result 0 | |
378 | } | |
40ac1624 | 379 | -re "(${question_string})$" { |
787f6220 BM |
380 | send_gdb "$response_string\n"; |
381 | exp_continue; | |
382 | } | |
40ac1624 | 383 | -re "Undefined command:.*$gdb_prompt" { |
85174909 | 384 | perror "Undefined command \"$command\"." |
c79f61db | 385 | set result 1 |
19fa4a0a | 386 | } |
40ac1624 | 387 | -re "Ambiguous command.*$gdb_prompt $" { |
85174909 | 388 | perror "\"$command\" is not a unique command name." |
c79f61db | 389 | set result 1 |
19fa4a0a | 390 | } |
fb07c696 | 391 | -re "Program exited with code \[0-9\]+.*$gdb_prompt $" { |
f646eef4 | 392 | if ![string match "" $message] then { |
787f6220 | 393 | set errmsg "$message: the program exited" |
f646eef4 | 394 | } else { |
787f6220 | 395 | set errmsg "$command: the program exited" |
f646eef4 | 396 | } |
787f6220 | 397 | fail "$errmsg" |
f646eef4 FF |
398 | return -1 |
399 | } | |
40ac1624 | 400 | -re "The program is not being run.*$gdb_prompt $" { |
f646eef4 FF |
401 | if ![string match "" $message] then { |
402 | set errmsg "$message: the program is no longer running" | |
403 | } else { | |
404 | set errmsg "$command: the program is no longer running" | |
405 | } | |
787f6220 | 406 | fail "$errmsg" |
f646eef4 FF |
407 | return -1 |
408 | } | |
40ac1624 | 409 | -re ".*$gdb_prompt $" { |
19fa4a0a MW |
410 | if ![string match "" $message] then { |
411 | fail "$message" | |
412 | } | |
413 | set result 1 | |
414 | } | |
40ac1624 | 415 | "<return>" { |
787f6220 | 416 | send_gdb "\n" |
85174909 | 417 | perror "Window too small." |
19fa4a0a | 418 | } |
40ac1624 | 419 | -re "\\(y or n\\) " { |
787f6220 | 420 | send_gdb "n\n" |
85174909 | 421 | perror "Got interactive prompt." |
19fa4a0a | 422 | } |
40ac1624 BM |
423 | eof { |
424 | perror "Process no longer exists" | |
425 | if { $message != "" } { | |
426 | fail "$message" | |
427 | } | |
428 | return -1 | |
c79f61db | 429 | } |
40ac1624 | 430 | full_buffer { |
85174909 | 431 | perror "internal buffer is full." |
19fa4a0a | 432 | } |
19fa4a0a | 433 | timeout { |
3e304ddf | 434 | if ![string match "" $message] then { |
40ac1624 | 435 | fail "$message (timeout)" |
3e304ddf | 436 | } |
19fa4a0a MW |
437 | set result 1 |
438 | } | |
439 | } | |
440 | return $result | |
441 | } | |
f34c8766 | 442 | \f |
a59f104e | 443 | # Test that a command gives an error. For pass or fail, return |
f34c8766 JK |
444 | # a 1 to indicate that more tests can proceed. However a timeout |
445 | # is a serious error, generates a special fail message, and causes | |
446 | # a 0 to be returned to indicate that more tests are likely to fail | |
447 | # as well. | |
448 | ||
449 | proc test_print_reject { args } { | |
85fbaa74 | 450 | global gdb_prompt |
f34c8766 JK |
451 | global verbose |
452 | ||
453 | if [llength $args]==2 then { | |
454 | set expectthis [lindex $args 1] | |
455 | } else { | |
456 | set expectthis "should never match this bogus string" | |
457 | } | |
458 | set sendthis [lindex $args 0] | |
459 | if $verbose>2 then { | |
460 | send_user "Sending \"$sendthis\" to gdb\n" | |
461 | send_user "Looking to match \"$expectthis\"\n" | |
462 | } | |
787f6220 | 463 | send_gdb "$sendthis\n" |
40ac1624 | 464 | gdb_expect { |
fb07c696 | 465 | -re "A .* in expression.*\\.*$gdb_prompt $" { |
f34c8766 JK |
466 | pass "reject $sendthis" |
467 | return 1 | |
468 | } | |
fb07c696 | 469 | -re "Invalid syntax in expression.*$gdb_prompt $" { |
f34c8766 JK |
470 | pass "reject $sendthis" |
471 | return 1 | |
472 | } | |
fb07c696 | 473 | -re "Junk after end of expression.*$gdb_prompt $" { |
f34c8766 JK |
474 | pass "reject $sendthis" |
475 | return 1 | |
476 | } | |
fb07c696 | 477 | -re "Invalid number.*$gdb_prompt $" { |
f34c8766 JK |
478 | pass "reject $sendthis" |
479 | return 1 | |
480 | } | |
fb07c696 | 481 | -re "Invalid character constant.*$gdb_prompt $" { |
f34c8766 JK |
482 | pass "reject $sendthis" |
483 | return 1 | |
484 | } | |
fb07c696 | 485 | -re "No symbol table is loaded.*$gdb_prompt $" { |
f34c8766 JK |
486 | pass "reject $sendthis" |
487 | return 1 | |
488 | } | |
fb07c696 | 489 | -re "No symbol .* in current context.*$gdb_prompt $" { |
f34c8766 JK |
490 | pass "reject $sendthis" |
491 | return 1 | |
492 | } | |
fb07c696 | 493 | -re "$expectthis.*$gdb_prompt $" { |
f34c8766 JK |
494 | pass "reject $sendthis" |
495 | return 1 | |
496 | } | |
85fbaa74 | 497 | -re ".*$gdb_prompt $" { |
f34c8766 JK |
498 | fail "reject $sendthis" |
499 | return 1 | |
500 | } | |
501 | default { | |
502 | fail "reject $sendthis (eof or timeout)" | |
503 | return 0 | |
504 | } | |
505 | } | |
506 | } | |
507 | \f | |
faa15770 PB |
508 | # Given an input string, adds backslashes as needed to create a |
509 | # regexp that will match the string. | |
3e304ddf | 510 | |
faa15770 | 511 | proc string_to_regexp {str} { |
3e304ddf C |
512 | set result $str |
513 | regsub -all {[]*+.|()^$\[]} $str {\\&} result | |
faa15770 PB |
514 | return $result |
515 | } | |
516 | ||
517 | # Same as gdb_test, but the second parameter is not a regexp, | |
518 | # but a string that must match exactly. | |
519 | ||
520 | proc gdb_test_exact { args } { | |
4771fe15 JL |
521 | upvar timeout timeout |
522 | ||
faa15770 | 523 | set command [lindex $args 0] |
787f6220 BM |
524 | |
525 | # This applies a special meaning to a null string pattern. Without | |
85fbaa74 | 526 | # this, "$pattern\r\n$gdb_prompt $" will match anything, including error |
787f6220 BM |
527 | # messages from commands that should have no output except a new |
528 | # prompt. With this, only results of a null string will match a null | |
529 | # string pattern. | |
530 | ||
531 | set pattern [lindex $args 1] | |
532 | if [string match $pattern ""] { | |
533 | set pattern [string_to_regexp [lindex $args 0]] | |
534 | } else { | |
535 | set pattern [string_to_regexp [lindex $args 1]] | |
536 | } | |
537 | ||
e7dc69ff FF |
538 | # It is most natural to write the pattern argument with only |
539 | # embedded \n's, especially if you are trying to avoid Tcl quoting | |
40ac1624 | 540 | # problems. But gdb_expect really wants to see \r\n in patterns. So |
e7dc69ff FF |
541 | # transform the pattern here. First transform \r\n back to \n, in |
542 | # case some users of gdb_test_exact already do the right thing. | |
543 | regsub -all "\r\n" $pattern "\n" pattern | |
544 | regsub -all "\n" $pattern "\r\n" pattern | |
faa15770 PB |
545 | if [llength $args]==3 then { |
546 | set message [lindex $args 2] | |
547 | } else { | |
548 | set message $command | |
549 | } | |
787f6220 | 550 | |
faa15770 PB |
551 | return [gdb_test $command $pattern $message] |
552 | } | |
f34c8766 | 553 | \f |
19fa4a0a | 554 | proc gdb_reinitialize_dir { subdir } { |
85fbaa74 | 555 | global gdb_prompt |
19fa4a0a | 556 | |
787f6220 BM |
557 | if [is_remote host] { |
558 | return ""; | |
559 | } | |
560 | send_gdb "dir\n" | |
40ac1624 | 561 | gdb_expect { |
4771fe15 | 562 | -re "Reinitialize source path to empty.*y or n. " { |
787f6220 | 563 | send_gdb "y\n" |
40ac1624 | 564 | gdb_expect { |
85fbaa74 | 565 | -re "Source directories searched.*$gdb_prompt $" { |
787f6220 | 566 | send_gdb "dir $subdir\n" |
40ac1624 | 567 | gdb_expect { |
85fbaa74 | 568 | -re "Source directories searched.*$gdb_prompt $" { |
85174909 | 569 | verbose "Dir set to $subdir" |
19fa4a0a | 570 | } |
fb07c696 | 571 | -re "$gdb_prompt $" { |
85174909 | 572 | perror "Dir \"$subdir\" failed." |
19fa4a0a MW |
573 | } |
574 | } | |
575 | } | |
fb07c696 | 576 | -re "$gdb_prompt $" { |
85174909 | 577 | perror "Dir \"$subdir\" failed." |
19fa4a0a MW |
578 | } |
579 | } | |
580 | } | |
fb07c696 | 581 | -re "$gdb_prompt $" { |
85174909 | 582 | perror "Dir \"$subdir\" failed." |
19fa4a0a MW |
583 | } |
584 | } | |
585 | } | |
c79f61db | 586 | |
c79f61db RS |
587 | # |
588 | # gdb_exit -- exit the GDB, killing the target program if necessary | |
589 | # | |
590 | proc default_gdb_exit {} { | |
591 | global GDB | |
592 | global GDBFLAGS | |
593 | global verbose | |
ae7872ef BM |
594 | global gdb_spawn_id; |
595 | ||
596 | gdb_stop_suppressing_tests; | |
787f6220 BM |
597 | |
598 | if ![info exists gdb_spawn_id] { | |
599 | return; | |
600 | } | |
c79f61db | 601 | |
002cc99f | 602 | verbose "Quitting $GDB $GDBFLAGS" |
c79f61db RS |
603 | |
604 | # This used to be 1 for unix-gdb.exp | |
605 | set timeout 5 | |
a26fa899 | 606 | verbose "Timeout is now $timeout seconds" 2 |
c79f61db | 607 | |
787f6220 BM |
608 | if [is_remote host] { |
609 | send_gdb "quit\n"; | |
40ac1624 | 610 | gdb_expect { |
fb07c696 | 611 | -re "and kill it.*y or n. " { |
787f6220 BM |
612 | send_gdb "y\n"; |
613 | exp_continue; | |
614 | } | |
ae7872ef | 615 | timeout { } |
787f6220 | 616 | } |
787f6220 | 617 | } |
90fba5fa | 618 | |
83b1cc25 | 619 | remote_close host; |
787f6220 | 620 | unset gdb_spawn_id |
c79f61db RS |
621 | } |
622 | ||
85174909 | 623 | # |
4771fe15 JL |
624 | # load a file into the debugger. |
625 | # return a -1 if anything goes wrong. | |
85174909 RS |
626 | # |
627 | proc gdb_file_cmd { arg } { | |
628 | global verbose | |
629 | global loadpath | |
630 | global loadfile | |
631 | global GDB | |
85fbaa74 | 632 | global gdb_prompt |
4771fe15 | 633 | upvar timeout timeout |
787f6220 BM |
634 | |
635 | if [is_remote host] { | |
636 | set arg [remote_download host $arg]; | |
637 | if { $arg == "" } { | |
638 | error "download failed" | |
639 | return -1; | |
640 | } | |
641 | } | |
85174909 | 642 | |
787f6220 | 643 | send_gdb "file $arg\n" |
40ac1624 | 644 | gdb_expect { |
85fbaa74 | 645 | -re "Reading symbols from.*done.*$gdb_prompt $" { |
85174909 RS |
646 | verbose "\t\tLoaded $arg into the $GDB" |
647 | return 0 | |
648 | } | |
85fbaa74 | 649 | -re "has no symbol-table.*$gdb_prompt $" { |
85174909 RS |
650 | perror "$arg wasn't compiled with \"-g\"" |
651 | return -1 | |
652 | } | |
9bcc6c3f | 653 | -re "A program is being debugged already.*Kill it.*y or n. $" { |
787f6220 | 654 | send_gdb "y\n" |
85174909 | 655 | verbose "\t\tKilling previous program being debugged" |
9bcc6c3f | 656 | exp_continue |
85174909 | 657 | } |
9bcc6c3f | 658 | -re "Load new symbol table from \".*\".*y or n. $" { |
787f6220 | 659 | send_gdb "y\n" |
40ac1624 | 660 | gdb_expect { |
85fbaa74 | 661 | -re "Reading symbols from.*done.*$gdb_prompt $" { |
85174909 RS |
662 | verbose "\t\tLoaded $arg with new symbol table into $GDB" |
663 | return 0 | |
664 | } | |
665 | timeout { | |
05a21390 | 666 | perror "(timeout) Couldn't load $arg, other program already loaded." |
85174909 RS |
667 | return -1 |
668 | } | |
669 | } | |
670 | } | |
fb07c696 | 671 | -re "No such file or directory.*$gdb_prompt $" { |
85174909 RS |
672 | perror "($arg) No such file or directory\n" |
673 | return -1 | |
674 | } | |
85fbaa74 | 675 | -re "$gdb_prompt $" { |
85174909 RS |
676 | perror "couldn't load $arg into $GDB." |
677 | return -1 | |
678 | } | |
679 | timeout { | |
9bcc6c3f | 680 | perror "couldn't load $arg into $GDB (timed out)." |
85174909 RS |
681 | return -1 |
682 | } | |
683 | eof { | |
684 | # This is an attempt to detect a core dump, but seems not to | |
685 | # work. Perhaps we need to match .* followed by eof, in which | |
40ac1624 | 686 | # gdb_expect does not seem to have a way to do that. |
8f07e537 | 687 | perror "couldn't load $arg into $GDB (end of file)." |
85174909 RS |
688 | return -1 |
689 | } | |
690 | } | |
691 | } | |
c79f61db | 692 | |
0fba9aa2 SS |
693 | # |
694 | # start gdb -- start gdb running, default procedure | |
695 | # | |
302fcffb FF |
696 | # When running over NFS, particularly if running many simultaneous |
697 | # tests on different hosts all using the same server, things can | |
698 | # get really slow. Give gdb at least 3 minutes to start up. | |
699 | # | |
0fba9aa2 SS |
700 | proc default_gdb_start { } { |
701 | global verbose | |
702 | global GDB | |
703 | global GDBFLAGS | |
85fbaa74 | 704 | global gdb_prompt |
0fba9aa2 | 705 | global timeout |
ae7872ef BM |
706 | global gdb_spawn_id; |
707 | ||
708 | gdb_stop_suppressing_tests; | |
709 | ||
f34c8766 | 710 | verbose "Spawning $GDB -nw $GDBFLAGS" |
3e304ddf | 711 | |
787f6220 BM |
712 | if [info exists gdb_spawn_id] { |
713 | return 0; | |
3e304ddf | 714 | } |
787f6220 | 715 | |
0fba9aa2 | 716 | set oldtimeout $timeout |
302fcffb | 717 | set timeout [expr "$timeout + 180"] |
787f6220 | 718 | if [is_remote host] { |
ae7872ef | 719 | set res [remote_spawn host "$GDB -nw $GDBFLAGS --command gdbinit"]; |
787f6220 BM |
720 | } else { |
721 | if { [which $GDB] == 0 } then { | |
722 | perror "$GDB does not exist." | |
723 | exit 1 | |
724 | } | |
725 | ||
ae7872ef BM |
726 | set res [remote_spawn host "$GDB -nw $GDBFLAGS"]; |
727 | } | |
728 | if { $res < 0 || $res == "" } { | |
ddb594ac BM |
729 | perror "Spawning $GDB failed." |
730 | return 1; | |
787f6220 | 731 | } |
787f6220 | 732 | set timeout 10 |
ae7872ef | 733 | gdb_expect { |
fb07c696 | 734 | -re "\[\r\n\]$gdb_prompt $" { |
3e304ddf | 735 | verbose "GDB initialized." |
0fba9aa2 | 736 | } |
ae7872ef | 737 | -re "$gdb_prompt $" { |
0fba9aa2 | 738 | perror "GDB never initialized." |
302fcffb FF |
739 | set timeout $oldtimeout |
740 | verbose "Timeout restored to $timeout seconds" 2 | |
0fba9aa2 SS |
741 | return -1 |
742 | } | |
ae7872ef | 743 | timeout { |
302fcffb | 744 | perror "(timeout) GDB never initialized after $timeout seconds." |
77f3ac77 | 745 | remote_close host; |
0fba9aa2 SS |
746 | return -1 |
747 | } | |
748 | } | |
749 | set timeout $oldtimeout | |
302fcffb | 750 | verbose "Timeout restored to $timeout seconds" 2 |
ae7872ef | 751 | set gdb_spawn_id -1; |
0fba9aa2 | 752 | # force the height to "unlimited", so no pagers get used |
40ac1624 | 753 | |
787f6220 | 754 | send_gdb "set height 0\n" |
40ac1624 | 755 | gdb_expect { |
fb07c696 | 756 | -re "$gdb_prompt $" { |
0fba9aa2 SS |
757 | verbose "Setting height to 0." 2 |
758 | } | |
40ac1624 | 759 | timeout { |
787f6220 | 760 | warning "Couldn't set the height to 0" |
0fba9aa2 SS |
761 | } |
762 | } | |
763 | # force the width to "unlimited", so no wraparound occurs | |
787f6220 | 764 | send_gdb "set width 0\n" |
40ac1624 | 765 | gdb_expect { |
fb07c696 | 766 | -re "$gdb_prompt $" { |
4771fe15 | 767 | verbose "Setting width to 0." 2 |
0fba9aa2 | 768 | } |
40ac1624 | 769 | timeout { |
0fba9aa2 SS |
770 | warning "Couldn't set the width to 0." |
771 | } | |
772 | } | |
787f6220 | 773 | return 0; |
0fba9aa2 SS |
774 | } |
775 | ||
9bcc6c3f RS |
776 | # |
777 | # FIXME: this is a copy of the new library procedure, but it's here too | |
778 | # till the new dejagnu gets installed everywhere. I'd hate to break the | |
787f6220 | 779 | # gdb testsuite. |
9bcc6c3f | 780 | # |
002cc99f RS |
781 | global argv0 |
782 | if ![info exists argv0] then { | |
9bcc6c3f RS |
783 | proc exp_continue { } { |
784 | continue -expect | |
785 | } | |
786 | } | |
c79f61db | 787 | |
4771fe15 JL |
788 | # * For crosses, the CHILL runtime doesn't build because it can't find |
789 | # setjmp.h, stdio.h, etc. | |
790 | # * For AIX (as of 16 Mar 95), (a) there is no language code for | |
791 | # CHILL in output_epilog in gcc/config/rs6000/rs6000.c, (b) collect2 | |
792 | # does not get along with AIX's too-clever linker. | |
793 | # * On Irix5, there is a bug whereby set of bool, etc., don't get | |
794 | # TYPE_LOW_BOUND for the bool right because force_to_range_type doesn't | |
795 | # work with stub types. | |
796 | # Lots of things seem to fail on the PA, and since it's not a supported | |
797 | # chill target at the moment, don't run the chill tests. | |
798 | ||
4081daa1 | 799 | proc skip_chill_tests {} { |
787f6220 BM |
800 | if ![info exists do_chill_tests] { |
801 | return 1; | |
802 | } | |
803 | eval set skip_chill [expr ![isnative] || [istarget "*-*-aix*"] || [istarget "*-*-irix5*"] || [istarget "*-*-irix6*"] || [istarget "alpha-*-osf*"] || [istarget "hppa*-*-*"]] | |
4771fe15 JL |
804 | verbose "Skip chill tests is $skip_chill" |
805 | return $skip_chill | |
4081daa1 | 806 | } |
787f6220 BM |
807 | |
808 | proc get_compiler_info {binfile} { | |
809 | # Create and source the file that provides information about the compiler | |
810 | # used to compile the test case. | |
811 | global srcdir | |
812 | global subdir | |
813 | # These two come from compiler.c. | |
814 | global signed_keyword_not_used | |
815 | global gcc_compiled | |
816 | ||
817 | if { [gdb_compile "${srcdir}/${subdir}/compiler.c" "${binfile}.ci" preprocess {}] != "" } { | |
818 | perror "Couldn't make ${binfile}.ci file" | |
819 | return 1; | |
820 | } | |
821 | source ${binfile}.ci | |
822 | return 0; | |
823 | } | |
824 | ||
825 | proc gdb_compile {source dest type options} { | |
ddb594ac BM |
826 | global GDB_TESTCASE_OPTIONS; |
827 | ||
787f6220 BM |
828 | if [target_info exists gdb_stub] { |
829 | set options2 { "additional_flags=-Dusestubs" } | |
830 | lappend options "libs=[target_info gdb_stub]"; | |
831 | set options [concat $options2 $options] | |
832 | } | |
ddb594ac BM |
833 | if [info exists GDB_TESTCASE_OPTIONS] { |
834 | lappend options "additional_flags=$GDB_TESTCASE_OPTIONS"; | |
835 | } | |
787f6220 BM |
836 | verbose "options are $options" |
837 | verbose "source is $source $dest $type $options" | |
838 | set result [target_compile $source $dest $type $options]; | |
839 | regsub "\[\r\n\]*$" "$result" "" result; | |
840 | regsub "^\[\r\n\]*" "$result" "" result; | |
841 | if { $result != "" } { | |
842 | clone_output "gdb compile failed, $result" | |
843 | } | |
844 | return $result; | |
845 | } | |
846 | ||
847 | proc send_gdb { string } { | |
ae7872ef BM |
848 | global suppress_flag; |
849 | if { $suppress_flag } { | |
850 | return "suppressed"; | |
851 | } | |
787f6220 BM |
852 | return [remote_send host "$string"]; |
853 | } | |
854 | ||
40ac1624 | 855 | # |
40ac1624 BM |
856 | # |
857 | ||
858 | proc gdb_expect { args } { | |
c55809ce BM |
859 | upvar timeout timeout |
860 | if [target_info exists gdb,timeout] { | |
d8b63305 | 861 | if [info exists timeout] { |
19d31cb3 BM |
862 | set oldt $timeout; |
863 | if { $timeout < [target_info gdb,timeout] } { | |
864 | set timeout [target_info gdb,timeout]; | |
865 | } | |
866 | } else { | |
867 | set timeout [target_info gdb,timeout]; | |
d8b63305 | 868 | } |
c55809ce | 869 | } |
77f3ac77 | 870 | set code [catch {uplevel remote_expect host $timeout $args} string]; |
d8b63305 BM |
871 | if [target_info exists gdb,timeout] { |
872 | if [info exists oldt] { | |
19d31cb3 | 873 | set timeout $oldt |
d8b63305 BM |
874 | } else { |
875 | unset timeout | |
876 | } | |
c55809ce | 877 | } |
40ac1624 BM |
878 | |
879 | if {$code == 1} { | |
17b59a74 BM |
880 | global errorInfo errorCode; |
881 | ||
40ac1624 BM |
882 | return -code error -errorinfo $errorInfo -errorcode $errorCode $string |
883 | } elseif {$code == 2} { | |
884 | return -code return $string | |
885 | } elseif {$code == 3} { | |
886 | return | |
887 | } elseif {$code > 4} { | |
888 | return -code $code $string | |
889 | } | |
890 | } | |
891 | ||
ae7872ef BM |
892 | # |
893 | # Set suppress_flag, which will cause all subsequent calls to send_gdb and | |
894 | # gdb_expect to fail immediately (until the next call to | |
895 | # gdb_stop_suppressing_tests). | |
896 | # | |
ddb594ac | 897 | proc gdb_suppress_tests { args } { |
ae7872ef BM |
898 | global suppress_flag; |
899 | ||
900 | incr suppress_flag; | |
ddb594ac BM |
901 | |
902 | if { [llength $args] > 0 } { | |
903 | warning "[lindex $args 0]\n"; | |
904 | } else { | |
905 | warning "Because of previous failure, all subsequent tests in this group will automatically fail.\n"; | |
906 | } | |
ae7872ef BM |
907 | } |
908 | ||
909 | # | |
910 | # Clear suppress_flag. | |
911 | # | |
912 | proc gdb_stop_suppressing_tests { } { | |
913 | global suppress_flag; | |
914 | ||
fb07c696 BM |
915 | if [info exists suppress_flag] { |
916 | if { $suppress_flag != 0 } { | |
917 | set suppress_flag 0; | |
918 | clone_output "Tests restarted.\n"; | |
919 | } | |
920 | } else { | |
921 | set suppress_flag 0; | |
922 | } | |
ae7872ef BM |
923 | } |
924 | ||
787f6220 BM |
925 | proc gdb_start { } { |
926 | default_gdb_start | |
927 | } | |
928 | ||
929 | proc gdb_exit { } { | |
930 | catch default_gdb_exit | |
931 | } | |
932 | ||
933 | # | |
934 | # gdb_load -- load a file into the debugger. | |
935 | # return a -1 if anything goes wrong. | |
936 | # | |
937 | proc gdb_load { arg } { | |
938 | return [gdb_file_cmd $arg] | |
939 | } | |
940 | ||
941 | proc gdb_continue { function } { | |
942 | global decimal | |
943 | ||
944 | return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"]; | |
945 | } | |
946 | ||
77f3ac77 | 947 | proc default_gdb_init { args } { |
ae7872ef BM |
948 | gdb_stop_suppressing_tests; |
949 | ||
950 | # Uh, this is lame. Really, really, really lame. But there's this *one* | |
951 | # testcase that will fail in random places if we don't increase this. | |
952 | match_max -d 20000 | |
953 | ||
ddb594ac | 954 | # We want to add the name of the TCL testcase to the PASS/FAIL messages. |
eb659148 BM |
955 | if { [llength $args] > 0 } { |
956 | global pf_prefix | |
957 | ||
958 | set file [lindex $args 0]; | |
959 | ||
960 | set pf_prefix "[file tail [file dirname $file]]/[file tail $file]:"; | |
961 | } | |
962 | } | |
963 | ||
77f3ac77 BM |
964 | proc gdb_init { args } { |
965 | return [default_gdb_init]; | |
966 | } | |
967 | ||
787f6220 BM |
968 | proc gdb_finish { } { |
969 | gdb_exit; | |
970 | } |