OpenCores
URL https://opencores.org/ocsvn/or1k/or1k/trunk

Subversion Repositories or1k

[/] [or1k/] [trunk/] [gdb-5.0/] [gdb/] [testsuite/] [lib/] [gdb.exp] - Blame information for rev 1765

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 106 markom
# Copyright (C) 1992, 1994, 1995, 1997, 1999 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 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
15
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
16
 
17
# Please email any bugs, comments, and/or additions to this file to:
18
# bug-gdb@prep.ai.mit.edu
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
 
26
load_lib libgloss.exp
27
 
28
global GDB
29
global CHILL_LIB
30
global CHILL_RT0
31
 
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]]
34
}
35
verbose "using CHILL_LIB = $CHILL_LIB" 2
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" ""]
38
}
39
verbose "using CHILL_RT0 = $CHILL_RT0" 2
40
 
41
if [info exists TOOL_EXECUTABLE] {
42
    set GDB $TOOL_EXECUTABLE;
43
}
44
if ![info exists GDB] {
45
    if ![is_remote host] {
46
        set GDB [findfile $base_dir/../../gdb/gdb "$base_dir/../../gdb/gdb" [transform gdb]]
47
    } else {
48
        set GDB [transform gdb];
49
    }
50
}
51
verbose "using GDB = $GDB" 2
52
 
53
global GDBFLAGS
54
if ![info exists GDBFLAGS] {
55
    set GDBFLAGS "-nx"
56
}
57
verbose "using GDBFLAGS = $GDBFLAGS" 2
58
 
59
# The variable gdb_prompt is a regexp which matches the gdb prompt.
60
# Set it if it is not already set.
61
global gdb_prompt
62
if ![info exists gdb_prompt] then {
63
    set gdb_prompt "\[(\]gdb\[)\]"
64
}
65
 
66
### Only procedures should come after this point.
67
 
68
#
69
# gdb_version -- extract and print the version number of GDB
70
#
71
proc default_gdb_version {} {
72
    global GDB
73
    global GDBFLAGS
74
    global gdb_prompt
75
    set fileid [open "gdb_cmd" w];
76
    puts $fileid "q";
77
    close $fileid;
78
    set cmdfile [remote_download host "gdb_cmd"];
79
    set output [remote_exec host "$GDB -nw --command $cmdfile"]
80
    remote_file build delete "gdb_cmd";
81
    remote_file host delete "$cmdfile";
82
    set tmp [lindex $output 1];
83
    set version ""
84
    regexp " \[0-9\]\[^ \t\n\r\]+" "$tmp" version
85
    if ![is_remote host] {
86
        clone_output "[which $GDB] version $version $GDBFLAGS\n"
87
    } else {
88
        clone_output "$GDB on remote host version $version $GDBFLAGS\n"
89
    }
90
}
91
 
92
proc gdb_version { } {
93
    return [default_gdb_version];
94
}
95
 
96
#
97
# gdb_unload -- unload a file if one is loaded
98
#
99
 
100
proc gdb_unload {} {
101
    global verbose
102
    global GDB
103
    global gdb_prompt
104
    send_gdb "file\n"
105
    gdb_expect 60 {
106
        -re "No executable file now\[^\r\n\]*\[\r\n\]" { exp_continue }
107
        -re "No symbol file now\[^\r\n\]*\[\r\n\]" { exp_continue }
108
        -re "A program is being debugged already..*Kill it.*y or n. $"\
109
            { send_gdb "y\n"
110
                verbose "\t\tKilling previous program being debugged"
111
            exp_continue
112
        }
113
        -re "Discard symbol table from .*y or n.*$" {
114
            send_gdb "y\n"
115
            exp_continue
116
        }
117
        -re "$gdb_prompt $" {}
118
        timeout {
119
            perror "couldn't unload file in $GDB (timed out)."
120
            return -1
121
        }
122
    }
123
}
124
 
125
# Many of the tests depend on setting breakpoints at various places and
126
# running until that breakpoint is reached.  At times, we want to start
127
# with a clean-slate with respect to breakpoints, so this utility proc
128
# lets us do this without duplicating this code everywhere.
129
#
130
 
131
proc delete_breakpoints {} {
132
    global gdb_prompt
133
 
134
    # we need a larger timeout value here or this thing just confuses
135
    # itself.  May need a better implementation if possible. - guo
136
    #
137
    send_gdb "delete breakpoints\n"
138
    gdb_expect 100 {
139
         -re "Delete all breakpoints.*y or n.*$" {
140
            send_gdb "y\n";
141
            exp_continue
142
        }
143
         -re "$gdb_prompt $" { # This happens if there were no breakpoints
144
            }
145
         timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return }
146
    }
147
    send_gdb "info breakpoints\n"
148
    gdb_expect 100 {
149
         -re "No breakpoints or watchpoints..*$gdb_prompt $" {}
150
         -re "$gdb_prompt $" { perror "breakpoints not deleted" ; return }
151
         -re "Delete all breakpoints.*or n.*$" {
152
            send_gdb "y\n";
153
            exp_continue
154
        }
155
         timeout { perror "info breakpoints (timeout)" ; return }
156
    }
157
}
158
 
159
 
160
#
161
# Generic run command.
162
#
163
# The second pattern below matches up to the first newline *only*.
164
# Using ``.*$'' could swallow up output that we attempt to match
165
# elsewhere.
166
#
167
proc gdb_run_cmd {args} {
168
    global gdb_prompt
169
 
170
    if [target_info exists gdb_init_command] {
171
        send_gdb "[target_info gdb_init_command]\n";
172
        gdb_expect 30 {
173
            -re "$gdb_prompt $" { }
174
            default {
175
                perror "gdb_init_command for target failed";
176
                return;
177
            }
178
        }
179
    }
180
 
181
    if [target_info exists use_gdb_stub] {
182
        if [target_info exists gdb,do_reload_on_run] {
183
            # Specifying no file, defaults to the executable
184
            # currently being debugged.
185
            if { [gdb_load ""] < 0 } {
186
                return;
187
            }
188
            send_gdb "continue\n";
189
            gdb_expect 60 {
190
                -re "Continu\[^\r\n\]*\[\r\n\]" {}
191
                default {}
192
            }
193
            return;
194
        }
195
 
196
        if [target_info exists gdb,start_symbol] {
197
            set start [target_info gdb,start_symbol];
198
        } else {
199
            set start "start";
200
        }
201
        send_gdb  "jump *$start\n"
202
        set start_attempt 1;
203
        while { $start_attempt } {
204
            # Cap (re)start attempts at three to ensure that this loop
205
            # always eventually fails.  Don't worry about trying to be
206
            # clever and not send a command when it has failed.
207
            if [expr $start_attempt > 3] {
208
                perror "Jump to start() failed (retry count exceeded)";
209
                return;
210
            }
211
            set start_attempt [expr $start_attempt + 1];
212
            gdb_expect 30 {
213
                -re "Continuing at \[^\r\n\]*\[\r\n\]" {
214
                    set start_attempt 0;
215
                }
216
                -re "No symbol \"_start\" in current.*$gdb_prompt $" {
217
                    perror "Can't find start symbol to run in gdb_run";
218
                    return;
219
                }
220
                -re "No symbol \"start\" in current.*$gdb_prompt $" {
221
                    send_gdb "jump *_start\n";
222
                }
223
                -re "No symbol.*context.*$gdb_prompt $" {
224
                    set start_attempt 0;
225
                }
226
                -re "Line.* Jump anyway.*y or n. $" {
227
                    send_gdb "y\n"
228
                }
229
                -re "The program is not being run.*$gdb_prompt $" {
230
                    if { [gdb_load ""] < 0 } {
231
                        return;
232
                    }
233
                    send_gdb "jump *$start\n";
234
                }
235
                timeout {
236
                    perror "Jump to start() failed (timeout)";
237
                    return
238
                }
239
            }
240
        }
241
        if [target_info exists gdb_stub] {
242
            gdb_expect 60 {
243
                -re "$gdb_prompt $" {
244
                    send_gdb "continue\n"
245
                }
246
            }
247
        }
248
        return
249
    }
250
    send_gdb "run $args\n"
251
# This doesn't work quite right yet.
252
    gdb_expect 60 {
253
        -re "The program .* has been started already.*y or n. $" {
254
            send_gdb "y\n"
255
            exp_continue
256
        }
257
        -re "Starting program: \[^\r\n\]*" {}
258
    }
259
}
260
 
261
proc gdb_breakpoint { function } {
262
    global gdb_prompt
263
    global decimal
264
 
265
    send_gdb "break $function\n"
266
    # The first two regexps are what we get with -g, the third is without -g.
267
    gdb_expect 30 {
268
        -re "Breakpoint \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {}
269
        -re "Breakpoint \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {}
270
        -re "Breakpoint \[0-9\]* at .*$gdb_prompt $" {}
271
        -re "$gdb_prompt $" { fail "setting breakpoint at $function" ; return 0 }
272
        timeout { fail "setting breakpoint at $function (timeout)" ; return 0 }
273
    }
274
    return 1;
275
}
276
 
277
# Set breakpoint at function and run gdb until it breaks there.
278
# Since this is the only breakpoint that will be set, if it stops
279
# at a breakpoint, we will assume it is the one we want.  We can't
280
# just compare to "function" because it might be a fully qualified,
281
# single quoted C++ function specifier.
282
 
283
proc runto { function } {
284
    global gdb_prompt
285
    global decimal
286
 
287
    delete_breakpoints
288
 
289
    if ![gdb_breakpoint $function] {
290
        return 0;
291
    }
292
 
293
    gdb_run_cmd
294
 
295
    # the "at foo.c:36" output we get with -g.
296
    # the "in func" output we get without -g.
297
    gdb_expect 30 {
298
        -re "Break.* at .*:$decimal.*$gdb_prompt $" {
299
            return 1
300
        }
301
        -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in .*$gdb_prompt $" {
302
            return 1
303
        }
304
        -re "$gdb_prompt $" {
305
            fail "running to $function in runto"
306
            return 0
307
        }
308
        timeout {
309
            fail "running to $function in runto (timeout)"
310
            return 0
311
        }
312
    }
313
    return 1
314
}
315
 
316
#
317
# runto_main -- ask gdb to run until we hit a breakpoint at main.
318
#               The case where the target uses stubs has to be handled
319
#               specially--if it uses stubs, assuming we hit
320
#               breakpoint() and just step out of the function.
321
#
322
proc runto_main { } {
323
    global gdb_prompt
324
    global decimal
325
 
326
    if ![target_info exists gdb_stub] {
327
        return [runto main]
328
    }
329
 
330
    delete_breakpoints
331
 
332
    gdb_step_for_stub;
333
 
334
    return 1
335
}
336
 
337
 
338
### Continue, and expect to hit a breakpoint.
339
### Report a pass or fail, depending on whether it seems to have
340
### worked.  Use NAME as part of the test name; each call to
341
### continue_to_breakpoint should use a NAME which is unique within
342
### that test file.
343
proc gdb_continue_to_breakpoint {name} {
344
    global gdb_prompt
345
    set full_name "continue to breakpoint: $name"
346
 
347
    send_gdb "continue\n"
348
    gdb_expect {
349
        -re "Breakpoint .* at .*\r\n$gdb_prompt $" {
350
            pass $full_name
351
        }
352
        -re ".*$gdb_prompt $" {
353
            fail $full_name
354
        }
355
        timeout {
356
            fail "$full_name (timeout)"
357
        }
358
    }
359
}
360
 
361
 
362
 
363
# gdb_test COMMAND PATTERN MESSAGE -- send a command to gdb; test the result.
364
#
365
# COMMAND is the command to execute, send to GDB with send_gdb.  If
366
#   this is the null string no command is sent.
367
# PATTERN is the pattern to match for a PASS, and must NOT include
368
#   the \r\n sequence immediately before the gdb prompt.
369
# MESSAGE is an optional message to be printed.  If this is
370
#   omitted, then the pass/fail messages use the command string as the
371
#   message.  (If this is the empty string, then sometimes we don't
372
#   call pass or fail at all; I don't understand this at all.)
373
#
374
# Returns:
375
#    1 if the test failed,
376
#    0 if the test passes,
377
#   -1 if there was an internal error.
378
#
379
proc gdb_test { args } {
380
    global verbose
381
    global gdb_prompt
382
    global GDB
383
    upvar timeout timeout
384
 
385
    if [llength $args]>2 then {
386
        set message [lindex $args 2]
387
    } else {
388
        set message [lindex $args 0]
389
    }
390
    set command [lindex $args 0]
391
    set pattern [lindex $args 1]
392
 
393
    if [llength $args]==5 {
394
        set question_string [lindex $args 3];
395
        set response_string [lindex $args 4];
396
    } else {
397
        set question_string "^FOOBAR$"
398
    }
399
 
400
    if $verbose>2 then {
401
        send_user "Sending \"$command\" to gdb\n"
402
        send_user "Looking to match \"$pattern\"\n"
403
        send_user "Message is \"$message\"\n"
404
    }
405
 
406
    set result -1
407
    set string "${command}\n";
408
    if { $command != "" } {
409
        while { "$string" != "" } {
410
            set foo [string first "\n" "$string"];
411
            set len [string length "$string"];
412
            if { $foo < [expr $len - 1] } {
413
                set str [string range "$string" 0 $foo];
414
                if { [send_gdb "$str"] != "" } {
415
                    global suppress_flag;
416
 
417
                    if { ! $suppress_flag } {
418
                        perror "Couldn't send $command to GDB.";
419
                    }
420
                    fail "$message";
421
                    return $result;
422
                }
423
                # since we're checking if each line of the multi-line
424
                # command are 'accepted' by GDB here,
425
                # we need to set -notransfer expect option so that
426
                # command output is not lost for pattern matching
427
                # - guo
428
                gdb_expect -notransfer 2 {
429
                    -re "\[\r\n\]" { }
430
                    timeout { }
431
                }
432
                set string [string range "$string" [expr $foo + 1] end];
433
            } else {
434
                break;
435
            }
436
        }
437
        if { "$string" != "" } {
438
            if { [send_gdb "$string"] != "" } {
439
                global suppress_flag;
440
 
441
                if { ! $suppress_flag } {
442
                    perror "Couldn't send $command to GDB.";
443
                }
444
                fail "$message";
445
                return $result;
446
            }
447
        }
448
    }
449
 
450
    if [info exists timeout] {
451
        set tmt $timeout;
452
    } else {
453
        global timeout;
454
        if [info exists timeout] {
455
            set tmt $timeout;
456
        } else {
457
            set tmt 60;
458
        }
459
    }
460
    gdb_expect $tmt {
461
         -re "\\*\\*\\* DOSEXIT code.*" {
462
             if { $message != "" } {
463
                 fail "$message";
464
             }
465
             gdb_suppress_entire_file "GDB died";
466
             return -1;
467
         }
468
         -re "Ending remote debugging.*$gdb_prompt $" {
469
            if ![isnative] then {
470
                warning "Can`t communicate to remote target."
471
            }
472
            gdb_exit
473
            gdb_start
474
            set result -1
475
        }
476
         -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" {
477
            if ![string match "" $message] then {
478
                pass "$message"
479
            }
480
            set result 0
481
        }
482
         -re "(${question_string})$" {
483
            send_gdb "$response_string\n";
484
            exp_continue;
485
        }
486
         -re "Undefined\[a-z\]* command:.*$gdb_prompt $" {
487
            perror "Undefined command \"$command\"."
488
            fail "$message"
489
            set result 1
490
        }
491
         -re "Ambiguous command.*$gdb_prompt $" {
492
            perror "\"$command\" is not a unique command name."
493
            fail "$message"
494
            set result 1
495
        }
496
         -re "Program exited with code \[0-9\]+.*$gdb_prompt $" {
497
            if ![string match "" $message] then {
498
                set errmsg "$message: the program exited"
499
            } else {
500
                set errmsg "$command: the program exited"
501
            }
502
            fail "$errmsg"
503
            return -1
504
        }
505
         -re "The program is not being run.*$gdb_prompt $" {
506
            if ![string match "" $message] then {
507
                set errmsg "$message: the program is no longer running"
508
            } else {
509
                set errmsg "$command: the program is no longer running"
510
            }
511
            fail "$errmsg"
512
            return -1
513
        }
514
         -re ".*$gdb_prompt $" {
515
            if ![string match "" $message] then {
516
                fail "$message"
517
            }
518
            set result 1
519
        }
520
         "" {
521
            send_gdb "\n"
522
            perror "Window too small."
523
            fail "$message"
524
        }
525
         -re "\\(y or n\\) " {
526
            send_gdb "n\n"
527
            perror "Got interactive prompt."
528
            fail "$message"
529
        }
530
         eof {
531
             perror "Process no longer exists"
532
             if { $message != "" } {
533
                 fail "$message"
534
             }
535
             return -1
536
        }
537
         full_buffer {
538
            perror "internal buffer is full."
539
            fail "$message"
540
        }
541
        timeout {
542
            if ![string match "" $message] then {
543
                fail "$message (timeout)"
544
            }
545
            set result 1
546
        }
547
    }
548
    return $result
549
}
550
 
551
# Test that a command gives an error.  For pass or fail, return
552
# a 1 to indicate that more tests can proceed.  However a timeout
553
# is a serious error, generates a special fail message, and causes
554
# a 0 to be returned to indicate that more tests are likely to fail
555
# as well.
556
 
557
proc test_print_reject { args } {
558
    global gdb_prompt
559
    global verbose
560
 
561
    if [llength $args]==2 then {
562
        set expectthis [lindex $args 1]
563
    } else {
564
        set expectthis "should never match this bogus string"
565
    }
566
    set sendthis [lindex $args 0]
567
    if $verbose>2 then {
568
        send_user "Sending \"$sendthis\" to gdb\n"
569
        send_user "Looking to match \"$expectthis\"\n"
570
    }
571
    send_gdb "$sendthis\n"
572
    #FIXME: Should add timeout as parameter.
573
    gdb_expect {
574
        -re "A .* in expression.*\\.*$gdb_prompt $" {
575
            pass "reject $sendthis"
576
            return 1
577
        }
578
        -re "Invalid syntax in expression.*$gdb_prompt $" {
579
            pass "reject $sendthis"
580
            return 1
581
        }
582
        -re "Junk after end of expression.*$gdb_prompt $" {
583
            pass "reject $sendthis"
584
            return 1
585
        }
586
        -re "Invalid number.*$gdb_prompt $" {
587
            pass "reject $sendthis"
588
            return 1
589
        }
590
        -re "Invalid character constant.*$gdb_prompt $" {
591
            pass "reject $sendthis"
592
            return 1
593
        }
594
        -re "No symbol table is loaded.*$gdb_prompt $" {
595
            pass "reject $sendthis"
596
            return 1
597
        }
598
        -re "No symbol .* in current context.*$gdb_prompt $" {
599
            pass "reject $sendthis"
600
            return 1
601
        }
602
        -re "$expectthis.*$gdb_prompt $" {
603
            pass "reject $sendthis"
604
            return 1
605
        }
606
        -re ".*$gdb_prompt $" {
607
            fail "reject $sendthis"
608
            return 1
609
        }
610
        default {
611
            fail "reject $sendthis (eof or timeout)"
612
            return 0
613
        }
614
    }
615
}
616
 
617
# Given an input string, adds backslashes as needed to create a
618
# regexp that will match the string.
619
 
620
proc string_to_regexp {str} {
621
    set result $str
622
    regsub -all {[]*+.|()^$\[]} $str {\\&} result
623
    return $result
624
}
625
 
626
# Same as gdb_test, but the second parameter is not a regexp,
627
# but a string that must match exactly.
628
 
629
proc gdb_test_exact { args } {
630
    upvar timeout timeout
631
 
632
    set command [lindex $args 0]
633
 
634
    # This applies a special meaning to a null string pattern.  Without
635
    # this, "$pattern\r\n$gdb_prompt $" will match anything, including error
636
    # messages from commands that should have no output except a new
637
    # prompt.  With this, only results of a null string will match a null
638
    # string pattern.
639
 
640
    set pattern [lindex $args 1]
641
    if [string match $pattern ""] {
642
        set pattern [string_to_regexp [lindex $args 0]]
643
    } else {
644
        set pattern [string_to_regexp [lindex $args 1]]
645
    }
646
 
647
    # It is most natural to write the pattern argument with only
648
    # embedded \n's, especially if you are trying to avoid Tcl quoting
649
    # problems.  But gdb_expect really wants to see \r\n in patterns.  So
650
    # transform the pattern here.  First transform \r\n back to \n, in
651
    # case some users of gdb_test_exact already do the right thing.
652
    regsub -all "\r\n" $pattern "\n" pattern
653
    regsub -all "\n" $pattern "\r\n" pattern
654
    if [llength $args]==3 then {
655
        set message [lindex $args 2]
656
    } else {
657
        set message $command
658
    }
659
 
660
    return [gdb_test $command $pattern $message]
661
}
662
 
663
proc gdb_reinitialize_dir { subdir } {
664
    global gdb_prompt
665
 
666
    if [is_remote host] {
667
        return "";
668
    }
669
    send_gdb "dir\n"
670
    gdb_expect 60 {
671
        -re "Reinitialize source path to empty.*y or n. " {
672
            send_gdb "y\n"
673
            gdb_expect 60 {
674
                -re "Source directories searched.*$gdb_prompt $" {
675
                    send_gdb "dir $subdir\n"
676
                    gdb_expect 60 {
677
                        -re "Source directories searched.*$gdb_prompt $" {
678
                            verbose "Dir set to $subdir"
679
                        }
680
                        -re "$gdb_prompt $" {
681
                            perror "Dir \"$subdir\" failed."
682
                        }
683
                    }
684
                }
685
                -re "$gdb_prompt $" {
686
                    perror "Dir \"$subdir\" failed."
687
                }
688
            }
689
        }
690
        -re "$gdb_prompt $" {
691
            perror "Dir \"$subdir\" failed."
692
        }
693
    }
694
}
695
 
696
#
697
# gdb_exit -- exit the GDB, killing the target program if necessary
698
#
699
proc default_gdb_exit {} {
700
    global GDB
701
    global GDBFLAGS
702
    global verbose
703
    global gdb_spawn_id;
704
 
705
    gdb_stop_suppressing_tests;
706
 
707
    if ![info exists gdb_spawn_id] {
708
        return;
709
    }
710
 
711
    verbose "Quitting $GDB $GDBFLAGS"
712
 
713
    if { [is_remote host] && [board_info host exists fileid] } {
714
        send_gdb "quit\n";
715
        gdb_expect 10 {
716
            -re "y or n" {
717
                send_gdb "y\n";
718
                exp_continue;
719
            }
720
            -re "DOSEXIT code" { }
721
            default { }
722
        }
723
    }
724
 
725
    if ![is_remote host] {
726
        remote_close host;
727
    }
728
    unset gdb_spawn_id
729
}
730
 
731
#
732
# load a file into the debugger.
733
# return a -1 if anything goes wrong.
734
#
735
proc gdb_file_cmd { arg } {
736
    global verbose
737
    global loadpath
738
    global loadfile
739
    global GDB
740
    global gdb_prompt
741
    upvar timeout timeout
742
 
743
    if [is_remote host] {
744
        set arg [remote_download host $arg];
745
        if { $arg == "" } {
746
            error "download failed"
747
            return -1;
748
        }
749
    }
750
 
751
    send_gdb "file $arg\n"
752
    gdb_expect 120 {
753
        -re "Reading symbols from.*done.*$gdb_prompt $" {
754
            verbose "\t\tLoaded $arg into the $GDB"
755
            return 0
756
        }
757
        -re "has no symbol-table.*$gdb_prompt $" {
758
            perror "$arg wasn't compiled with \"-g\""
759
            return -1
760
        }
761
        -re "A program is being debugged already.*Kill it.*y or n. $" {
762
            send_gdb "y\n"
763
                verbose "\t\tKilling previous program being debugged"
764
            exp_continue
765
        }
766
        -re "Load new symbol table from \".*\".*y or n. $" {
767
            send_gdb "y\n"
768
            gdb_expect 120 {
769
                -re "Reading symbols from.*done.*$gdb_prompt $" {
770
                    verbose "\t\tLoaded $arg with new symbol table into $GDB"
771
                    return 0
772
                }
773
                timeout {
774
                    perror "(timeout) Couldn't load $arg, other program already loaded."
775
                    return -1
776
                }
777
            }
778
        }
779
        -re "No such file or directory.*$gdb_prompt $" {
780
            perror "($arg) No such file or directory\n"
781
            return -1
782
        }
783
        -re "$gdb_prompt $" {
784
            perror "couldn't load $arg into $GDB."
785
            return -1
786
            }
787
        timeout {
788
            perror "couldn't load $arg into $GDB (timed out)."
789
            return -1
790
        }
791
        eof {
792
            # This is an attempt to detect a core dump, but seems not to
793
            # work.  Perhaps we need to match .* followed by eof, in which
794
            # gdb_expect does not seem to have a way to do that.
795
            perror "couldn't load $arg into $GDB (end of file)."
796
            return -1
797
        }
798
    }
799
}
800
 
801
#
802
# start gdb -- start gdb running, default procedure
803
#
804
# When running over NFS, particularly if running many simultaneous
805
# tests on different hosts all using the same server, things can
806
# get really slow.  Give gdb at least 3 minutes to start up.
807
#
808
proc default_gdb_start { } {
809
    global verbose
810
    global GDB
811
    global GDBFLAGS
812
    global gdb_prompt
813
    global timeout
814
    global gdb_spawn_id;
815
 
816
    gdb_stop_suppressing_tests;
817
 
818
    verbose "Spawning $GDB -nw $GDBFLAGS"
819
 
820
    if [info exists gdb_spawn_id] {
821
        return 0;
822
    }
823
 
824
    if ![is_remote host] {
825
        if { [which $GDB] == 0 } then {
826
            perror "$GDB does not exist."
827
            exit 1
828
        }
829
    }
830
    set res [remote_spawn host "$GDB -nw $GDBFLAGS [host_info gdb_opts]"];
831
    if { $res < 0 || $res == "" } {
832
        perror "Spawning $GDB failed."
833
        return 1;
834
    }
835
    gdb_expect 360 {
836
        -re "\[\r\n\]$gdb_prompt $" {
837
            verbose "GDB initialized."
838
        }
839
        -re "$gdb_prompt $"     {
840
            perror "GDB never initialized."
841
            return -1
842
        }
843
        timeout {
844
            perror "(timeout) GDB never initialized after 10 seconds."
845
            remote_close host;
846
            return -1
847
        }
848
    }
849
    set gdb_spawn_id -1;
850
    # force the height to "unlimited", so no pagers get used
851
 
852
    send_gdb "set height 0\n"
853
    gdb_expect 10 {
854
        -re "$gdb_prompt $" {
855
            verbose "Setting height to 0." 2
856
        }
857
        timeout {
858
            warning "Couldn't set the height to 0"
859
        }
860
    }
861
    # force the width to "unlimited", so no wraparound occurs
862
    send_gdb "set width 0\n"
863
    gdb_expect 10 {
864
        -re "$gdb_prompt $" {
865
            verbose "Setting width to 0." 2
866
        }
867
        timeout {
868
            warning "Couldn't set the width to 0."
869
        }
870
    }
871
    return 0;
872
}
873
 
874
# Return a 1 for configurations for which we don't even want to try to
875
# test C++.
876
 
877
proc skip_cplus_tests {} {
878
    if { [istarget "d10v-*-*"] } {
879
        return 1
880
    }
881
    if { [istarget "h8300-*-*"] } {
882
        return 1
883
    }
884
    return 0
885
}
886
 
887
# * For crosses, the CHILL runtime doesn't build because it can't find
888
# setjmp.h, stdio.h, etc.
889
# * For AIX (as of 16 Mar 95), (a) there is no language code for
890
# CHILL in output_epilog in gcc/config/rs6000/rs6000.c, (b) collect2
891
# does not get along with AIX's too-clever linker.
892
# * On Irix5, there is a bug whereby set of bool, etc., don't get
893
# TYPE_LOW_BOUND for the bool right because force_to_range_type doesn't
894
# work with stub types.
895
# Lots of things seem to fail on the PA, and since it's not a supported
896
# chill target at the moment, don't run the chill tests.
897
 
898
proc skip_chill_tests {} {
899
    if ![info exists do_chill_tests] {
900
        return 1;
901
    }
902
    eval set skip_chill [expr ![isnative] || [istarget "*-*-aix*"] || [istarget "*-*-irix5*"] || [istarget "*-*-irix6*"] || [istarget "alpha-*-osf*"] || [istarget "hppa*-*-*"]]
903
    verbose "Skip chill tests is $skip_chill"
904
    return $skip_chill
905
}
906
 
907
# Skip all the tests in the file if you are not on an hppa running
908
# hpux target.
909
 
910
proc skip_hp_tests {} {
911
    eval set skip_hp [ expr ![isnative] || ![istarget "hppa*-*-hpux*"] ]
912
    verbose "Skip hp tests is $skip_hp"
913
    return $skip_hp
914
}
915
 
916
proc get_compiler_info {binfile args} {
917
    # Create and source the file that provides information about the compiler
918
    # used to compile the test case.
919
    # Compiler_type can be null or c++. If null we assume c.
920
    global srcdir
921
    global subdir
922
    # These two come from compiler.c.
923
    global signed_keyword_not_used
924
    global gcc_compiled
925
 
926
    if {![istarget "hppa*-*-hpux*"]} {
927
        if { [llength $args] > 0 } {
928
            if {$args == "c++"} {
929
                if { [gdb_compile "${srcdir}/lib/compiler.cc" "${binfile}.ci" preprocess {}] != "" } {
930
                    perror "Couldn't make ${binfile}.ci file"
931
                    return 1;
932
                }
933
            }
934
        } else {
935
            if { [gdb_compile "${srcdir}/lib/compiler.c" "${binfile}.ci" preprocess {}] != "" } {
936
                perror "Couldn't make ${binfile}.ci file"
937
                return 1;
938
            }
939
        }
940
    } else {
941
        if { [llength $args] > 0 } {
942
            if {$args == "c++"} {
943
                if { [eval gdb_preprocess \
944
                        [list "${srcdir}/lib/compiler.cc" "${binfile}.ci"] \
945
                        $args] != "" } {
946
                    perror "Couldn't make ${binfile}.ci file"
947
                    return 1;
948
                }
949
            }
950
        } elseif { $args != "f77" } {
951
            if { [eval gdb_preprocess \
952
                    [list "${srcdir}/lib/compiler.c" "${binfile}.ci"] \
953
                    $args] != "" } {
954
                perror "Couldn't make ${binfile}.ci file"
955
                return 1;
956
            }
957
        }
958
    }
959
 
960
    uplevel \#0 { set gcc_compiled 0 }
961
 
962
    if { [llength $args] == 0 || $args != "f77" } {
963
        source ${binfile}.ci
964
    }
965
 
966
    # Most compilers will evaluate comparisons and other boolean
967
    # operations to 0 or 1.
968
    uplevel \#0 { set true 1 }
969
    uplevel \#0 { set false 0 }
970
 
971
    uplevel \#0 { set hp_cc_compiler 0 }
972
    uplevel \#0 { set hp_aCC_compiler 0 }
973
    uplevel \#0 { set hp_f77_compiler 0 }
974
    uplevel \#0 { set hp_f90_compiler 0 }
975
    if { !$gcc_compiled && [istarget "hppa*-*-hpux*"] } {
976
        # Check for the HP compilers
977
        set compiler [lindex [split [get_compiler $args] " "] 0]
978
        catch "exec what $compiler" output
979
        if [regexp ".*HP aC\\+\\+.*" $output] {
980
            uplevel \#0 { set hp_aCC_compiler 1 }
981
            # Use of aCC results in boolean results being displayed as
982
            # "true" or "false"
983
            uplevel \#0 { set true true }
984
            uplevel \#0 { set false false }
985
        } elseif [regexp ".*HP C Compiler.*" $output] {
986
            uplevel \#0 { set hp_cc_compiler 1 }
987
        } elseif [regexp ".*HP-UX f77.*" $output] {
988
            uplevel \#0 { set hp_f77_compiler 1 }
989
        } elseif [regexp ".*HP-UX f90.*" $output] {
990
            uplevel \#0 { set hp_f90_compiler 1 }
991
        }
992
    }
993
 
994
    return 0;
995
}
996
 
997
proc get_compiler {args} {
998
    global CC CC_FOR_TARGET CXX CXX_FOR_TARGET F77_FOR_TARGET
999
 
1000
    if { [llength $args] == 0
1001
         || ([llength $args] == 1 && [lindex $args 0] == "") } {
1002
        set which_compiler "c"
1003
    } else {
1004
        if { $args =="c++" } {
1005
            set which_compiler "c++"
1006
        } elseif { $args =="f77" } {
1007
            set which_compiler "f77"
1008
        } else {
1009
            perror "Unknown compiler type supplied to gdb_preprocess"
1010
            return ""
1011
        }
1012
    }
1013
 
1014
    if [info exists CC_FOR_TARGET] {
1015
        if {$which_compiler == "c"} {
1016
            set compiler $CC_FOR_TARGET
1017
        }
1018
    }
1019
 
1020
    if [info exists CXX_FOR_TARGET] {
1021
        if {$which_compiler == "c++"} {
1022
            set compiler $CXX_FOR_TARGET
1023
        }
1024
    }
1025
 
1026
    if [info exists F77_FOR_TARGET] {
1027
        if {$which_compiler == "f77"} {
1028
            set compiler $F77_FOR_TARGET
1029
        }
1030
    }
1031
 
1032
    if { ![info exists compiler] } {
1033
        if { $which_compiler == "c" } {
1034
            if {[info exists CC]} {
1035
                set compiler $CC
1036
            }
1037
        }
1038
        if { $which_compiler == "c++" } {
1039
            if {[info exists CXX]} {
1040
                set compiler $CXX
1041
            }
1042
        }
1043
        if {![info exists compiler]} {
1044
            set compiler [board_info [target_info name] compiler];
1045
            if { $compiler == "" } {
1046
                perror "get_compiler: No compiler found"
1047
                return ""
1048
            }
1049
        }
1050
    }
1051
 
1052
    return $compiler
1053
}
1054
 
1055
proc gdb_preprocess {source dest args} {
1056
    set compiler [get_compiler "$args"]
1057
    if { $compiler == "" } {
1058
        return 1
1059
    }
1060
 
1061
    set cmdline "$compiler -E $source > $dest"
1062
 
1063
    verbose "Invoking $compiler -E $source > $dest"
1064
    verbose -log "Executing on local host: $cmdline" 2
1065
    set status [catch "exec ${cmdline}" exec_output]
1066
 
1067
    set result [prune_warnings $exec_output]
1068
    regsub "\[\r\n\]*$" "$result" "" result;
1069
    regsub "^\[\r\n\]*" "$result" "" result;
1070
    if { $result != "" } {
1071
        clone_output "gdb compile failed, $result"
1072
    }
1073
    return $result;
1074
}
1075
 
1076
proc gdb_compile {source dest type options} {
1077
    global GDB_TESTCASE_OPTIONS;
1078
 
1079
    if [target_info exists gdb_stub] {
1080
        set options2 { "additional_flags=-Dusestubs" }
1081
        lappend options "libs=[target_info gdb_stub]";
1082
        set options [concat $options2 $options]
1083
    }
1084
    if [target_info exists is_vxworks] {
1085
        set options2 { "additional_flags=-Dvxworks" }
1086
        lappend options "libs=[target_info gdb_stub]";
1087
        set options [concat $options2 $options]
1088
    }
1089
    if [info exists GDB_TESTCASE_OPTIONS] {
1090
        lappend options "additional_flags=$GDB_TESTCASE_OPTIONS";
1091
    }
1092
    verbose "options are $options"
1093
    verbose "source is $source $dest $type $options"
1094
 
1095
    set result [target_compile $source $dest $type $options];
1096
    regsub "\[\r\n\]*$" "$result" "" result;
1097
    regsub "^\[\r\n\]*" "$result" "" result;
1098
    if { $result != "" } {
1099
        clone_output "gdb compile failed, $result"
1100
    }
1101
    return $result;
1102
}
1103
 
1104
proc send_gdb { string } {
1105
    global suppress_flag;
1106
    if { $suppress_flag } {
1107
        return "suppressed";
1108
    }
1109
    return [remote_send host "$string"];
1110
}
1111
 
1112
#
1113
#
1114
 
1115
proc gdb_expect { args } {
1116
    # allow -notransfer expect flag specification,
1117
    # used by gdb_test routine for multi-line commands.
1118
    # packed with gtimeout when fed to remote_expect routine,
1119
    # which is a hack but due to what looks like a res and orig
1120
    # parsing problem in remote_expect routine (dejagnu/lib/remote.exp):
1121
    # what's fed into res is not removed from orig.
1122
    # - guo
1123
    if { [lindex $args 0] == "-notransfer" } {
1124
        set notransfer -notransfer;
1125
        set args [lrange $args 1 end];
1126
    } else {
1127
        set notransfer "";
1128
    }
1129
 
1130
    if { [llength $args] == 2  && [lindex $args 0] != "-re" } {
1131
        set gtimeout [lindex $args 0];
1132
        set expcode [list [lindex $args 1]];
1133
    } else {
1134
        upvar timeout timeout;
1135
 
1136
        set expcode $args;
1137
        if [target_info exists gdb,timeout] {
1138
            if [info exists timeout] {
1139
                if { $timeout < [target_info gdb,timeout] } {
1140
                    set gtimeout [target_info gdb,timeout];
1141
                } else {
1142
                    set gtimeout $timeout;
1143
                }
1144
            } else {
1145
                set gtimeout [target_info gdb,timeout];
1146
            }
1147
        }
1148
 
1149
        if ![info exists gtimeout] {
1150
            global timeout;
1151
            if [info exists timeout] {
1152
                set gtimeout $timeout;
1153
            } else {
1154
                # Eeeeew.
1155
                set gtimeout 60;
1156
            }
1157
        }
1158
    }
1159
    global suppress_flag;
1160
    global remote_suppress_flag;
1161
    if [info exists remote_suppress_flag] {
1162
        set old_val $remote_suppress_flag;
1163
    }
1164
    if [info exists suppress_flag] {
1165
        if { $suppress_flag } {
1166
            set remote_suppress_flag 1;
1167
        }
1168
    }
1169
    set code [catch \
1170
        {uplevel remote_expect host "$gtimeout $notransfer" $expcode} string];
1171
    if [info exists old_val] {
1172
        set remote_suppress_flag $old_val;
1173
    } else {
1174
        if [info exists remote_suppress_flag] {
1175
            unset remote_suppress_flag;
1176
        }
1177
    }
1178
 
1179
    if {$code == 1} {
1180
        global errorInfo errorCode;
1181
 
1182
        return -code error -errorinfo $errorInfo -errorcode $errorCode $string
1183
    } elseif {$code == 2} {
1184
        return -code return $string
1185
    } elseif {$code == 3} {
1186
        return
1187
    } elseif {$code > 4} {
1188
        return -code $code $string
1189
    }
1190
}
1191
 
1192
# gdb_expect_list MESSAGE SENTINEL LIST -- expect a sequence of outputs
1193
#
1194
# Check for long sequence of output by parts.
1195
# MESSAGE: is the test message to be printed with the test success/fail.
1196
# SENTINEL: Is the terminal pattern indicating that output has finished.
1197
# LIST: is the sequence of outputs to match.
1198
# If the sentinel is recognized early, it is considered an error.
1199
#
1200
# Returns:
1201
#    1 if the test failed,
1202
#    0 if the test passes,
1203
#   -1 if there was an internal error.
1204
#
1205
proc gdb_expect_list {test sentinel list} {
1206
    global gdb_prompt
1207
    global suppress_flag
1208
    set index 0
1209
    set ok 1
1210
    if { $suppress_flag } {
1211
        set ok 0
1212
    }
1213
    while { ${index} < [llength ${list}] } {
1214
        set pattern [lindex ${list} ${index}]
1215
        set index [expr ${index} + 1]
1216
        if { ${index} == [llength ${list}] } {
1217
            if { ${ok} } {
1218
                gdb_expect {
1219
                    -re "${pattern}${sentinel}" {
1220
                        pass "${test}, pattern ${index} + sentinel"
1221
                    }
1222
                    -re "${sentinel}" {
1223
                        fail "${test}, pattern ${index} + sentinel"
1224
                        set ok 0
1225
                    }
1226
                    timeout {
1227
                        fail "${test}, pattern ${index} + sentinel (timeout)"
1228
                        set ok 0
1229
                    }
1230
                }
1231
            } else {
1232
                unresolved "${test}, pattern ${index} + sentinel"
1233
            }
1234
        } else {
1235
            if { ${ok} } {
1236
                gdb_expect {
1237
                    -re "${pattern}" {
1238
                        pass "${test}, pattern ${index}"
1239
                    }
1240
                    -re "${sentinel}" {
1241
                        fail "${test}, pattern ${index}"
1242
                        set ok 0
1243
                    }
1244
                    timeout {
1245
                        fail "${test}, pattern ${index} (timeout)"
1246
                        set ok 0
1247
                    }
1248
                }
1249
            } else {
1250
                unresolved "${test}, pattern ${index}"
1251
            }
1252
        }
1253
    }
1254
    if { ${ok} } {
1255
        return 0
1256
    } else {
1257
        return 1
1258
    }
1259
}
1260
 
1261
#
1262
#
1263
proc gdb_suppress_entire_file { reason } {
1264
    global suppress_flag;
1265
 
1266
    warning "$reason\n";
1267
    set suppress_flag -1;
1268
}
1269
 
1270
#
1271
# Set suppress_flag, which will cause all subsequent calls to send_gdb and
1272
# gdb_expect to fail immediately (until the next call to
1273
# gdb_stop_suppressing_tests).
1274
#
1275
proc gdb_suppress_tests { args } {
1276
    global suppress_flag;
1277
 
1278
    return;  # fnf - disable pending review of results where
1279
             # testsuite ran better without this
1280
    incr suppress_flag;
1281
 
1282
    if { $suppress_flag == 1 } {
1283
        if { [llength $args] > 0 } {
1284
            warning "[lindex $args 0]\n";
1285
        } else {
1286
            warning "Because of previous failure, all subsequent tests in this group will automatically fail.\n";
1287
        }
1288
    }
1289
}
1290
 
1291
#
1292
# Clear suppress_flag.
1293
#
1294
proc gdb_stop_suppressing_tests { } {
1295
    global suppress_flag;
1296
 
1297
    if [info exists suppress_flag] {
1298
        if { $suppress_flag > 0 } {
1299
            set suppress_flag 0;
1300
            clone_output "Tests restarted.\n";
1301
        }
1302
    } else {
1303
        set suppress_flag 0;
1304
    }
1305
}
1306
 
1307
proc gdb_clear_suppressed { } {
1308
    global suppress_flag;
1309
 
1310
    set suppress_flag 0;
1311
}
1312
 
1313
proc gdb_start { } {
1314
    default_gdb_start
1315
}
1316
 
1317
proc gdb_exit { } {
1318
    catch default_gdb_exit
1319
}
1320
 
1321
#
1322
# gdb_load -- load a file into the debugger.
1323
#             return a -1 if anything goes wrong.
1324
#
1325
proc gdb_load { arg } {
1326
    return [gdb_file_cmd $arg]
1327
}
1328
 
1329
proc gdb_continue { function } {
1330
    global decimal
1331
 
1332
    return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"];
1333
}
1334
 
1335
proc default_gdb_init { args } {
1336
    gdb_clear_suppressed;
1337
 
1338
    # Uh, this is lame. Really, really, really lame. But there's this *one*
1339
    # testcase that will fail in random places if we don't increase this.
1340
    match_max -d 20000
1341
 
1342
    # We want to add the name of the TCL testcase to the PASS/FAIL messages.
1343
    if { [llength $args] > 0 } {
1344
        global pf_prefix
1345
 
1346
        set file [lindex $args 0];
1347
 
1348
        set pf_prefix "[file tail [file dirname $file]]/[file tail $file]:";
1349
    }
1350
    global gdb_prompt;
1351
    if [target_info exists gdb_prompt] {
1352
        set gdb_prompt [target_info gdb_prompt];
1353
    } else {
1354
        set gdb_prompt "\\(gdb\\)"
1355
    }
1356
}
1357
 
1358
proc gdb_init { args } {
1359
    return [eval default_gdb_init $args];
1360
}
1361
 
1362
proc gdb_finish { } {
1363
    gdb_exit;
1364
}
1365
 
1366
global debug_format
1367
set debug_format "unknown"
1368
 
1369
# Run the gdb command "info source" and extract the debugging format
1370
# information from the output and save it in debug_format.
1371
 
1372
proc get_debug_format { } {
1373
    global gdb_prompt
1374
    global verbose
1375
    global expect_out
1376
    global debug_format
1377
 
1378
    set debug_format "unknown"
1379
    send_gdb "info source\n"
1380
    gdb_expect 10 {
1381
        -re "Compiled with (.*) debugging format.\r\n$gdb_prompt $" {
1382
            set debug_format $expect_out(1,string)
1383
            verbose "debug format is $debug_format"
1384
            return 1;
1385
        }
1386
        -re "No current source file.\r\n$gdb_prompt $" {
1387
            perror "get_debug_format used when no current source file"
1388
            return 0;
1389
        }
1390
        -re "$gdb_prompt $" {
1391
            warning "couldn't check debug format (no valid response)."
1392
            return 1;
1393
        }
1394
        timeout {
1395
            warning "couldn't check debug format (timed out)."
1396
            return 1;
1397
        }
1398
    }
1399
}
1400
 
1401
# Like setup_xfail, but takes the name of a debug format (DWARF 1,
1402
# COFF, stabs, etc).  If that format matches the format that the
1403
# current test was compiled with, then the next test is expected to
1404
# fail for any target.  Returns 1 if the next test or set of tests is
1405
# expected to fail, 0 otherwise (or if it is unknown).  Must have
1406
# previously called get_debug_format.
1407
 
1408
proc setup_xfail_format { format } {
1409
    global debug_format
1410
 
1411
    if [string match $debug_format $format] then {
1412
        setup_xfail "*-*-*"
1413
        return 1;
1414
    }
1415
    return 0
1416
}
1417
 
1418
proc gdb_step_for_stub { } {
1419
    global gdb_prompt;
1420
 
1421
    if ![target_info exists gdb,use_breakpoint_for_stub] {
1422
        if [target_info exists gdb_stub_step_command] {
1423
            set command [target_info gdb_stub_step_command];
1424
        } else {
1425
            set command "step";
1426
        }
1427
        send_gdb "${command}\n";
1428
        set tries 0;
1429
        gdb_expect 60 {
1430
            -re "(main.* at |.*in .*start).*$gdb_prompt" {
1431
                return;
1432
            }
1433
            -re ".*$gdb_prompt" {
1434
                incr tries;
1435
                if { $tries == 5 } {
1436
                    fail "stepping out of breakpoint function";
1437
                    return;
1438
                }
1439
                send_gdb "${command}\n";
1440
                exp_continue;
1441
            }
1442
            default {
1443
                fail "stepping out of breakpoint function";
1444
                return;
1445
            }
1446
        }
1447
    }
1448
    send_gdb "where\n";
1449
    gdb_expect {
1450
        -re "main\[^\r\n\]*at \(\[^:]+\):\(\[0-9\]+\)" {
1451
            set file $expect_out(1,string);
1452
            set linenum [expr $expect_out(2,string) + 1];
1453
            set breakplace "${file}:${linenum}";
1454
        }
1455
        default {}
1456
    }
1457
    send_gdb "break ${breakplace}\n";
1458
    gdb_expect 60 {
1459
        -re "Breakpoint (\[0-9\]+) at.*$gdb_prompt" {
1460
            set breakpoint $expect_out(1,string);
1461
        }
1462
        -re "Breakpoint (\[0-9\]+): file.*$gdb_prompt" {
1463
            set breakpoint $expect_out(1,string);
1464
        }
1465
        default {}
1466
    }
1467
    send_gdb "continue\n";
1468
    gdb_expect 60 {
1469
        -re "Breakpoint ${breakpoint},.*$gdb_prompt" {
1470
            gdb_test "delete $breakpoint" ".*" "";
1471
            return;
1472
        }
1473
        default {}
1474
    }
1475
}
1476
 
1477
### gdb_get_line_number TEXT [FILE]
1478
###
1479
### Search the source file FILE, and return the line number of a line
1480
### containing TEXT.  Use this function instead of hard-coding line
1481
### numbers into your test script.
1482
###
1483
### Specifically, this function uses GDB's "search" command to search
1484
### FILE for the first line containing TEXT, and returns its line
1485
### number.  Thus, FILE must be a source file, compiled into the
1486
### executable you are running.  If omitted, FILE defaults to the
1487
### value of the global variable `srcfile'; most test scripts set
1488
### `srcfile' appropriately at the top anyway.
1489
###
1490
### Use this function to keep your test scripts independent of the
1491
### exact line numbering of the source file.  Don't write:
1492
###
1493
###   send_gdb "break 20"
1494
###
1495
### This means that if anyone ever edits your test's source file,
1496
### your test could break.  Instead, put a comment like this on the
1497
### source file line you want to break at:
1498
###
1499
###   /* breakpoint spot: frotz.exp: test name */
1500
###
1501
### and then write, in your test script (which we assume is named
1502
### frotz.exp):
1503
###
1504
###   send_gdb "break [gdb_get_line_number "frotz.exp: test name"]\n"
1505
###
1506
### (Yes, Tcl knows how to handle the nested quotes and brackets.
1507
### Try this:
1508
###     $ tclsh
1509
###     % puts "foo [lindex "bar baz" 1]"
1510
###     foo baz
1511
###     %
1512
### Tcl is quite clever, for a little stringy language.)
1513
 
1514
proc gdb_get_line_number {text {file /omitted/}} {
1515
    global gdb_prompt;
1516
    global srcfile;
1517
 
1518
    if {! [string compare $file /omitted/]} {
1519
        set file $srcfile
1520
    }
1521
 
1522
    set result -1;
1523
    gdb_test "list ${file}:1,1" ".*" ""
1524
    send_gdb "search ${text}\n"
1525
    gdb_expect {
1526
        -re "\[\r\n\]+(\[0-9\]+)\[ \t\].*${text}.*$gdb_prompt $" {
1527
            set result $expect_out(1,string)
1528
        }
1529
        -re ".*$gdb_prompt $" {
1530
            fail "find line number containing \"${text}\""
1531
        }
1532
        timeout {
1533
            fail "find line number containing \"${text}\" (timeout)"
1534
        }
1535
    }
1536
    return $result;
1537
}
1538
 
1539
# gdb_continue_to_end:
1540
#       The case where the target uses stubs has to be handled specially. If a
1541
#       stub is used, we set a breakpoint at exit because we cannot rely on
1542
#       exit() behavior of a remote target.
1543
#
1544
# mssg is the error message that gets printed.
1545
 
1546
proc gdb_continue_to_end {mssg} {
1547
  if [target_info exists use_gdb_stub] {
1548
    if {![gdb_breakpoint "exit"]} {
1549
      return 0
1550
    }
1551
    gdb_test "continue" "Continuing..*Breakpoint .*exit.*" \
1552
      "continue until exit at $mssg"
1553
  } else {
1554
    # Continue until we exit.  Should not stop again.
1555
    # Don't bother to check the output of the program, that may be
1556
    # extremely tough for some remote systems.
1557
    gdb_test "continue"\
1558
      "Continuing.\[\r\n0-9\]+Program exited normally\\..*"\
1559
      "continue until exit at $mssg"
1560
  }
1561
}
1562
 
1563
proc rerun_to_main {} {
1564
  global gdb_prompt
1565
 
1566
  if [target_info exists use_gdb_stub] {
1567
    gdb_run_cmd
1568
    gdb_expect {
1569
      -re ".*Breakpoint .*main .*$gdb_prompt $"\
1570
              {pass "rerun to main" ; return 0}
1571
      -re "$gdb_prompt $"\
1572
              {fail "rerun to main" ; return 0}
1573
      timeout {fail "(timeout) rerun to main" ; return 0}
1574
    }
1575
  } else {
1576
    send_gdb "run\n"
1577
    gdb_expect {
1578
      -re "Starting program.*$gdb_prompt $"\
1579
              {pass "rerun to main" ; return 0}
1580
      -re "$gdb_prompt $"\
1581
              {fail "rerun to main" ; return 0}
1582
      timeout {fail "(timeout) rerun to main" ; return 0}
1583
    }
1584
  }
1585
}
1586
 
1587
# From dejagnu:
1588
# srcdir = testsuite src dir (e.g., devo/gdb/testsuite)
1589
# objdir = testsuite obj dir (e.g., gdb/testsuite)
1590
# subdir = subdir of testsuite (e.g., gdb.gdbtk)
1591
#
1592
# To gdbtk:
1593
# env(DEFS)=the "defs" files (e.g., devo/gdb/testsuite/gdb.gdbtk/defs)
1594
# env(SRCDIR)=directory containing the test code (e.g., *.test)
1595
# env(OBJDIR)=directory which contains any executables
1596
#            (e.g., gdb/testsuite/gdb.gdbtk)
1597
proc gdbtk_start {test} {
1598
  global verbose
1599
  global GDB
1600
  global GDBFLAGS
1601
  global env srcdir subdir objdir
1602
 
1603
  gdb_stop_suppressing_tests;
1604
 
1605
  verbose "Starting $GDB -nx -q --tclcommand=$test"
1606
 
1607
  set real_test [which $test]
1608
  if {$real_test == 0} {
1609
    perror "$test is not found"
1610
    exit 1
1611
  }
1612
 
1613
  if {![is_remote host]} {
1614
    if { [which $GDB] == 0 } {
1615
      perror "$GDB does not exist."
1616
      exit 1
1617
    }
1618
  }
1619
 
1620
 
1621
  set wd [pwd]
1622
  cd $srcdir
1623
  set abs_srcdir [pwd]
1624
  cd [file join $abs_srcdir .. gdbtk library]
1625
  set env(GDBTK_LIBRARY) [pwd]
1626
  cd [file join $abs_srcdir .. .. tcl library]
1627
  set env(TCL_LIBRARY) [pwd]
1628
  cd [file join $abs_srcdir .. .. tk library]
1629
  set env(TK_LIBRARY) [pwd]
1630
  cd [file join $abs_srcdir .. .. tix library]
1631
  set env(TIX_LIBRARY) [pwd]
1632
  cd [file join $abs_srcdir .. .. itcl itcl library]
1633
  set env(ITCL_LIBRARY) [pwd]
1634
  cd [file join .. $abs_srcdir .. .. libgui library]
1635
  set env(CYGNUS_GUI_LIBRARY) [pwd]
1636
  cd $wd
1637
  cd [file join $abs_srcdir $subdir]
1638
  set env(DEFS) [file join [pwd] defs]
1639
  cd $wd
1640
  cd [file join $objdir $subdir]
1641
  set env(OBJDIR) [pwd]
1642
  cd $wd
1643
 
1644
  set env(SRCDIR) $abs_srcdir
1645
  set env(GDBTK_VERBOSE) 1
1646
  set env(GDBTK_LOGFILE) [file join $objdir gdb.log]
1647
  set env(GDBTK_TEST_RUNNING) 1
1648
  set err [catch {exec $GDB -nx -q --tclcommand=$test} res]
1649
  if { $err } {
1650
    perror "Execing $GDB failed: $res"
1651
    exit 1;
1652
  }
1653
  return $res
1654
}
1655
 
1656
# gdbtk tests call this function to print out the results of the
1657
# tests. The argument is a proper list of lists of the form:
1658
# {status name description msg}. All of these things typically
1659
# come from the testsuite harness.
1660
proc gdbtk_analyze_results {results} {
1661
  foreach test $results {
1662
    set status [lindex $test 0]
1663
    set name [lindex $test 1]
1664
    set description [lindex $test 2]
1665
    set msg [lindex $test 3]
1666
 
1667
    switch $status {
1668
      PASS {
1669
        pass "$description ($name)"
1670
      }
1671
 
1672
      FAIL {
1673
        fail "$description ($name)"
1674
      }
1675
 
1676
      ERROR {
1677
        perror "$name"
1678
      }
1679
 
1680
      XFAIL {
1681
        xfail "$description ($name)"
1682
      }
1683
 
1684
      XPASS {
1685
        xpass "$description ($name)"
1686
      }
1687
    }
1688
  }
1689
}

powered by: WebSVN 2.1.0

© copyright 1999-2024 OpenCores.org, equivalent to Oliscience, all rights reserved. OpenCores®, registered trademark.