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

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gdb-7.2/] [gdb/] [testsuite/] [lib/] [gdb.exp] - Blame information for rev 330

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 330 jeremybenn
# Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002,
2
# 2003, 2004, 2005, 2007, 2008, 2009, 2010 Free Software Foundation, Inc.
3
 
4
# This program is free software; you can redistribute it and/or modify
5
# it under the terms of the GNU General Public License as published by
6
# the Free Software Foundation; either version 3 of the License, or
7
# (at your option) any later version.
8
#
9
# This program is distributed in the hope that it will be useful,
10
# but WITHOUT ANY WARRANTY; without even the implied warranty of
11
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
12
# GNU General Public License for more details.
13
#
14
# You should have received a copy of the GNU General Public License
15
# along with this program.  If not, see .
16
 
17
# This file was written by Fred Fish. (fnf@cygnus.com)
18
 
19
# Generic gdb subroutines that should work for any target.  If these
20
# need to be modified for any target, it can be done with a variable
21
# or by passing arguments.
22
 
23
if {$tool == ""} {
24
    # Tests would fail, logs on get_compiler_info() would be missing.
25
    send_error "`site.exp' not found, run `make site.exp'!\n"
26
    exit 2
27
}
28
 
29
load_lib libgloss.exp
30
 
31
global GDB
32
 
33
if [info exists TOOL_EXECUTABLE] {
34
    set GDB $TOOL_EXECUTABLE;
35
}
36
if ![info exists GDB] {
37
    if ![is_remote host] {
38
        set GDB [findfile $base_dir/../../gdb/gdb "$base_dir/../../gdb/gdb" [transform gdb]]
39
    } else {
40
        set GDB [transform gdb];
41
    }
42
}
43
verbose "using GDB = $GDB" 2
44
 
45
# GDBFLAGS is available for the user to set on the command line.
46
# E.g. make check RUNTESTFLAGS=GDBFLAGS=mumble
47
# Testcases may use it to add additional flags, but they must:
48
# - append new flags, not overwrite
49
# - restore the original value when done
50
global GDBFLAGS
51
if ![info exists GDBFLAGS] {
52
    set GDBFLAGS ""
53
}
54
verbose "using GDBFLAGS = $GDBFLAGS" 2
55
 
56
# INTERNAL_GDBFLAGS contains flags that the testsuite requires.
57
global INTERNAL_GDBFLAGS
58
if ![info exists INTERNAL_GDBFLAGS] {
59
    set INTERNAL_GDBFLAGS "-nw -nx"
60
}
61
 
62
# The variable gdb_prompt is a regexp which matches the gdb prompt.
63
# Set it if it is not already set.
64
global gdb_prompt
65
if ![info exists gdb_prompt] then {
66
    set gdb_prompt "\[(\]gdb\[)\]"
67
}
68
 
69
# The variable fullname_syntax_POSIX is a regexp which matches a POSIX
70
# absolute path ie. /foo/
71
set fullname_syntax_POSIX {/[^\n]*/}
72
# The variable fullname_syntax_UNC is a regexp which matches a Windows
73
# UNC path ie. \\D\foo\
74
set fullname_syntax_UNC {\\\\[^\\]+\\[^\n]+\\}
75
# The variable fullname_syntax_DOS_CASE is a regexp which matches a
76
# particular DOS case that GDB most likely will output
77
# ie. \foo\, but don't match \\.*\
78
set fullname_syntax_DOS_CASE {\\[^\\][^\n]*\\}
79
# The variable fullname_syntax_DOS is a regexp which matches a DOS path
80
# ie. a:\foo\ && a:foo\
81
set fullname_syntax_DOS {[a-zA-Z]:[^\n]*\\}
82
# The variable fullname_syntax is a regexp which matches what GDB considers
83
# an absolute path. It is currently debatable if the Windows style paths
84
# d:foo and \abc should be considered valid as an absolute path.
85
# Also, the purpse of this regexp is not to recognize a well formed
86
# absolute path, but to say with certainty that a path is absolute.
87
set fullname_syntax "($fullname_syntax_POSIX|$fullname_syntax_UNC|$fullname_syntax_DOS_CASE|$fullname_syntax_DOS)"
88
 
89
# Needed for some tests under Cygwin.
90
global EXEEXT
91
global env
92
 
93
if ![info exists env(EXEEXT)] {
94
    set EXEEXT ""
95
} else {
96
    set EXEEXT $env(EXEEXT)
97
}
98
 
99
set octal "\[0-7\]+"
100
 
101
### Only procedures should come after this point.
102
 
103
#
104
# gdb_version -- extract and print the version number of GDB
105
#
106
proc default_gdb_version {} {
107
    global GDB
108
    global INTERNAL_GDBFLAGS GDBFLAGS
109
    global gdb_prompt
110
    set output [remote_exec host "$GDB $INTERNAL_GDBFLAGS --version"]
111
    set tmp [lindex $output 1];
112
    set version ""
113
    regexp " \[0-9\]\[^ \t\n\r\]+" "$tmp" version
114
    if ![is_remote host] {
115
        clone_output "[which $GDB] version $version $INTERNAL_GDBFLAGS $GDBFLAGS\n"
116
    } else {
117
        clone_output "$GDB on remote host version $version $INTERNAL_GDBFLAGS $GDBFLAGS\n"
118
    }
119
}
120
 
121
proc gdb_version { } {
122
    return [default_gdb_version];
123
}
124
 
125
#
126
# gdb_unload -- unload a file if one is loaded
127
#
128
 
129
proc gdb_unload {} {
130
    global verbose
131
    global GDB
132
    global gdb_prompt
133
    send_gdb "file\n"
134
    gdb_expect 60 {
135
        -re "No executable file now\[^\r\n\]*\[\r\n\]" { exp_continue }
136
        -re "No symbol file now\[^\r\n\]*\[\r\n\]" { exp_continue }
137
        -re "A program is being debugged already..*Kill it.*y or n. $"\
138
            { send_gdb "y\n"
139
                verbose "\t\tKilling previous program being debugged"
140
            exp_continue
141
        }
142
        -re "Discard symbol table from .*y or n.*$" {
143
            send_gdb "y\n"
144
            exp_continue
145
        }
146
        -re "$gdb_prompt $" {}
147
        timeout {
148
            perror "couldn't unload file in $GDB (timed out)."
149
            return -1
150
        }
151
    }
152
}
153
 
154
# Many of the tests depend on setting breakpoints at various places and
155
# running until that breakpoint is reached.  At times, we want to start
156
# with a clean-slate with respect to breakpoints, so this utility proc
157
# lets us do this without duplicating this code everywhere.
158
#
159
 
160
proc delete_breakpoints {} {
161
    global gdb_prompt
162
 
163
    # we need a larger timeout value here or this thing just confuses
164
    # itself.  May need a better implementation if possible. - guo
165
    #
166
    send_gdb "delete breakpoints\n"
167
    gdb_expect 100 {
168
         -re "Delete all breakpoints.*y or n.*$" {
169
            send_gdb "y\n";
170
            exp_continue
171
        }
172
         -re "$gdb_prompt $" { # This happens if there were no breakpoints
173
            }
174
         timeout { perror "Delete all breakpoints in delete_breakpoints (timeout)" ; return }
175
    }
176
    send_gdb "info breakpoints\n"
177
    gdb_expect 100 {
178
         -re "No breakpoints or watchpoints..*$gdb_prompt $" {}
179
         -re "$gdb_prompt $" { perror "breakpoints not deleted" ; return }
180
         -re "Delete all breakpoints.*or n.*$" {
181
            send_gdb "y\n";
182
            exp_continue
183
        }
184
         timeout { perror "info breakpoints (timeout)" ; return }
185
    }
186
}
187
 
188
 
189
#
190
# Generic run command.
191
#
192
# The second pattern below matches up to the first newline *only*.
193
# Using ``.*$'' could swallow up output that we attempt to match
194
# elsewhere.
195
#
196
proc gdb_run_cmd {args} {
197
    global gdb_prompt
198
 
199
    if [target_info exists gdb_init_command] {
200
        send_gdb "[target_info gdb_init_command]\n";
201
        gdb_expect 30 {
202
            -re "$gdb_prompt $" { }
203
            default {
204
                perror "gdb_init_command for target failed";
205
                return;
206
            }
207
        }
208
    }
209
 
210
    if [target_info exists use_gdb_stub] {
211
        if [target_info exists gdb,do_reload_on_run] {
212
            if { [gdb_reload] != 0 } {
213
                return;
214
            }
215
            send_gdb "continue\n";
216
            gdb_expect 60 {
217
                -re "Continu\[^\r\n\]*\[\r\n\]" {}
218
                default {}
219
            }
220
            return;
221
        }
222
 
223
        if [target_info exists gdb,start_symbol] {
224
            set start [target_info gdb,start_symbol];
225
        } else {
226
            set start "start";
227
        }
228
        send_gdb  "jump *$start\n"
229
        set start_attempt 1;
230
        while { $start_attempt } {
231
            # Cap (re)start attempts at three to ensure that this loop
232
            # always eventually fails.  Don't worry about trying to be
233
            # clever and not send a command when it has failed.
234
            if [expr $start_attempt > 3] {
235
                perror "Jump to start() failed (retry count exceeded)";
236
                return;
237
            }
238
            set start_attempt [expr $start_attempt + 1];
239
            gdb_expect 30 {
240
                -re "Continuing at \[^\r\n\]*\[\r\n\]" {
241
                    set start_attempt 0;
242
                }
243
                -re "No symbol \"_start\" in current.*$gdb_prompt $" {
244
                    perror "Can't find start symbol to run in gdb_run";
245
                    return;
246
                }
247
                -re "No symbol \"start\" in current.*$gdb_prompt $" {
248
                    send_gdb "jump *_start\n";
249
                }
250
                -re "No symbol.*context.*$gdb_prompt $" {
251
                    set start_attempt 0;
252
                }
253
                -re "Line.* Jump anyway.*y or n. $" {
254
                    send_gdb "y\n"
255
                }
256
                -re "The program is not being run.*$gdb_prompt $" {
257
                    if { [gdb_reload] != 0 } {
258
                        return;
259
                    }
260
                    send_gdb "jump *$start\n";
261
                }
262
                timeout {
263
                    perror "Jump to start() failed (timeout)";
264
                    return
265
                }
266
            }
267
        }
268
        if [target_info exists gdb_stub] {
269
            gdb_expect 60 {
270
                -re "$gdb_prompt $" {
271
                    send_gdb "continue\n"
272
                }
273
            }
274
        }
275
        return
276
    }
277
 
278
    if [target_info exists gdb,do_reload_on_run] {
279
        if { [gdb_reload] != 0 } {
280
            return;
281
        }
282
    }
283
    send_gdb "run $args\n"
284
# This doesn't work quite right yet.
285
# Use -notransfer here so that test cases (like chng-sym.exp)
286
# may test for additional start-up messages.
287
   gdb_expect 60 {
288
        -re "The program .* has been started already.*y or n. $" {
289
            send_gdb "y\n"
290
            exp_continue
291
        }
292
        -notransfer -re "Starting program: \[^\r\n\]*" {}
293
        -notransfer -re "$gdb_prompt $" {
294
            # There is no more input expected.
295
        }
296
    }
297
}
298
 
299
# Generic start command.  Return 0 if we could start the program, -1
300
# if we could not.
301
 
302
proc gdb_start_cmd {args} {
303
    global gdb_prompt
304
 
305
    if [target_info exists gdb_init_command] {
306
        send_gdb "[target_info gdb_init_command]\n";
307
        gdb_expect 30 {
308
            -re "$gdb_prompt $" { }
309
            default {
310
                perror "gdb_init_command for target failed";
311
                return;
312
            }
313
        }
314
    }
315
 
316
    if [target_info exists use_gdb_stub] {
317
        return -1
318
    }
319
 
320
    send_gdb "start $args\n"
321
    # Use -notransfer here so that test cases (like chng-sym.exp)
322
    # may test for additional start-up messages.
323
    gdb_expect 60 {
324
        -re "The program .* has been started already.*y or n. $" {
325
            send_gdb "y\n"
326
            exp_continue
327
        }
328
        -notransfer -re "Starting program: \[^\r\n\]*" {
329
            return 0
330
        }
331
    }
332
    return -1
333
}
334
 
335
# Set a breakpoint at FUNCTION.  If there is an additional argument it is
336
# a list of options; the supported options are allow-pending, temporary,
337
# and no-message.
338
 
339
proc gdb_breakpoint { function args } {
340
    global gdb_prompt
341
    global decimal
342
 
343
    set pending_response n
344
    if {[lsearch -exact [lindex $args 0] allow-pending] != -1} {
345
        set pending_response y
346
    }
347
 
348
    set break_command "break"
349
    set break_message "Breakpoint"
350
    if {[lsearch -exact [lindex $args 0] temporary] != -1} {
351
        set break_command "tbreak"
352
        set break_message "Temporary breakpoint"
353
    }
354
 
355
    set no_message 0
356
    if {[lsearch -exact [lindex $args 0] no-message] != -1} {
357
        set no_message 1
358
    }
359
 
360
    send_gdb "$break_command $function\n"
361
    # The first two regexps are what we get with -g, the third is without -g.
362
    gdb_expect 30 {
363
        -re "$break_message \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {}
364
        -re "$break_message \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {}
365
        -re "$break_message \[0-9\]* at .*$gdb_prompt $" {}
366
        -re "$break_message \[0-9\]* \\(.*\\) pending.*$gdb_prompt $" {
367
                if {$pending_response == "n"} {
368
                        if { $no_message == 0 } {
369
                                fail "setting breakpoint at $function"
370
                        }
371
                        return 0
372
                }
373
        }
374
        -re "Make breakpoint pending.*y or \\\[n\\\]. $" {
375
                send_gdb "$pending_response\n"
376
                exp_continue
377
        }
378
        -re "$gdb_prompt $" {
379
                if { $no_message == 0 } {
380
                        fail "setting breakpoint at $function"
381
                }
382
                return 0
383
        }
384
        timeout {
385
                if { $no_message == 0 } {
386
                        fail "setting breakpoint at $function (timeout)"
387
                }
388
                return 0
389
        }
390
    }
391
    return 1;
392
}
393
 
394
# Set breakpoint at function and run gdb until it breaks there.
395
# Since this is the only breakpoint that will be set, if it stops
396
# at a breakpoint, we will assume it is the one we want.  We can't
397
# just compare to "function" because it might be a fully qualified,
398
# single quoted C++ function specifier.  If there's an additional argument,
399
# pass it to gdb_breakpoint.
400
 
401
proc runto { function args } {
402
    global gdb_prompt
403
    global decimal
404
 
405
    delete_breakpoints
406
 
407
    if ![gdb_breakpoint $function [lindex $args 0]] {
408
        return 0;
409
    }
410
 
411
    gdb_run_cmd
412
 
413
    # the "at foo.c:36" output we get with -g.
414
    # the "in func" output we get without -g.
415
    gdb_expect 30 {
416
        -re "Break.* at .*:$decimal.*$gdb_prompt $" {
417
            return 1
418
        }
419
        -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in .*$gdb_prompt $" {
420
            return 1
421
        }
422
        -re "The target does not support running in non-stop mode.\r\n$gdb_prompt $" {
423
            unsupported "Non-stop mode not supported"
424
            return 0
425
        }
426
        -re ".*A problem internal to GDB has been detected" {
427
            fail "running to $function in runto (GDB internal error)"
428
            gdb_internal_error_resync
429
            return 0
430
        }
431
        -re "$gdb_prompt $" {
432
            fail "running to $function in runto"
433
            return 0
434
        }
435
        eof {
436
            fail "running to $function in runto (end of file)"
437
            return 0
438
        }
439
        timeout {
440
            fail "running to $function in runto (timeout)"
441
            return 0
442
        }
443
    }
444
    return 1
445
}
446
 
447
#
448
# runto_main -- ask gdb to run until we hit a breakpoint at main.
449
#               The case where the target uses stubs has to be handled
450
#               specially--if it uses stubs, assuming we hit
451
#               breakpoint() and just step out of the function.
452
#
453
proc runto_main { } {
454
    global gdb_prompt
455
    global decimal
456
 
457
    if ![target_info exists gdb_stub] {
458
        return [runto main]
459
    }
460
 
461
    delete_breakpoints
462
 
463
    gdb_step_for_stub;
464
 
465
    return 1
466
}
467
 
468
 
469
### Continue, and expect to hit a breakpoint.
470
### Report a pass or fail, depending on whether it seems to have
471
### worked.  Use NAME as part of the test name; each call to
472
### continue_to_breakpoint should use a NAME which is unique within
473
### that test file.
474
proc gdb_continue_to_breakpoint {name {location_pattern .*}} {
475
    global gdb_prompt
476
    set full_name "continue to breakpoint: $name"
477
 
478
    send_gdb "continue\n"
479
    gdb_expect {
480
        -re "Breakpoint .* (at|in) $location_pattern\r\n$gdb_prompt $" {
481
            pass $full_name
482
        }
483
        -re ".*$gdb_prompt $" {
484
            fail $full_name
485
        }
486
        timeout {
487
            fail "$full_name (timeout)"
488
        }
489
    }
490
}
491
 
492
 
493
# gdb_internal_error_resync:
494
#
495
# Answer the questions GDB asks after it reports an internal error
496
# until we get back to a GDB prompt.  Decline to quit the debugging
497
# session, and decline to create a core file.  Return non-zero if the
498
# resync succeeds.
499
#
500
# This procedure just answers whatever questions come up until it sees
501
# a GDB prompt; it doesn't require you to have matched the input up to
502
# any specific point.  However, it only answers questions it sees in
503
# the output itself, so if you've matched a question, you had better
504
# answer it yourself before calling this.
505
#
506
# You can use this function thus:
507
#
508
# gdb_expect {
509
#     ...
510
#     -re ".*A problem internal to GDB has been detected" {
511
#         gdb_internal_error_resync
512
#     }
513
#     ...
514
# }
515
#
516
proc gdb_internal_error_resync {} {
517
    global gdb_prompt
518
 
519
    set count 0
520
    while {$count < 10} {
521
        gdb_expect {
522
            -re "Quit this debugging session\\? \\(y or n\\) $" {
523
                send_gdb "n\n"
524
                incr count
525
            }
526
            -re "Create a core file of GDB\\? \\(y or n\\) $" {
527
                send_gdb "n\n"
528
                incr count
529
            }
530
            -re "$gdb_prompt $" {
531
                # We're resynchronized.
532
                return 1
533
            }
534
            timeout {
535
                perror "Could not resync from internal error (timeout)"
536
                return 0
537
            }
538
        }
539
    }
540
    perror "Could not resync from internal error (resync count exceeded)"
541
    return 0
542
}
543
 
544
 
545
# gdb_test_multiple COMMAND MESSAGE EXPECT_ARGUMENTS
546
# Send a command to gdb; test the result.
547
#
548
# COMMAND is the command to execute, send to GDB with send_gdb.  If
549
#   this is the null string no command is sent.
550
# MESSAGE is a message to be printed with the built-in failure patterns
551
#   if one of them matches.  If MESSAGE is empty COMMAND will be used.
552
# EXPECT_ARGUMENTS will be fed to expect in addition to the standard
553
#   patterns.  Pattern elements will be evaluated in the caller's
554
#   context; action elements will be executed in the caller's context.
555
#   Unlike patterns for gdb_test, these patterns should generally include
556
#   the final newline and prompt.
557
#
558
# Returns:
559
#    1 if the test failed, according to a built-in failure pattern
560
#    0 if only user-supplied patterns matched
561
#   -1 if there was an internal error.
562
#
563
# You can use this function thus:
564
#
565
# gdb_test_multiple "print foo" "test foo" {
566
#    -re "expected output 1" {
567
#        pass "print foo"
568
#    }
569
#    -re "expected output 2" {
570
#        fail "print foo"
571
#    }
572
# }
573
#
574
# The standard patterns, such as "Program exited..." and "A problem
575
# ...", all being implicitly appended to that list.
576
#
577
proc gdb_test_multiple { command message user_code } {
578
    global verbose
579
    global gdb_prompt
580
    global GDB
581
    upvar timeout timeout
582
    upvar expect_out expect_out
583
 
584
    if { $message == "" } {
585
        set message $command
586
    }
587
 
588
    if [string match "*\[\r\n\]" $command] {
589
        error "Invalid trailing newline in \"$message\" test"
590
    }
591
 
592
    # TCL/EXPECT WART ALERT
593
    # Expect does something very strange when it receives a single braced
594
    # argument.  It splits it along word separators and performs substitutions.
595
    # This means that { "[ab]" } is evaluated as "[ab]", but { "\[ab\]" } is
596
    # evaluated as "\[ab\]".  But that's not how TCL normally works; inside a
597
    # double-quoted list item, "\[ab\]" is just a long way of representing
598
    # "[ab]", because the backslashes will be removed by lindex.
599
 
600
    # Unfortunately, there appears to be no easy way to duplicate the splitting
601
    # that expect will do from within TCL.  And many places make use of the
602
    # "\[0-9\]" construct, so we need to support that; and some places make use
603
    # of the "[func]" construct, so we need to support that too.  In order to
604
    # get this right we have to substitute quoted list elements differently
605
    # from braced list elements.
606
 
607
    # We do this roughly the same way that Expect does it.  We have to use two
608
    # lists, because if we leave unquoted newlines in the argument to uplevel
609
    # they'll be treated as command separators, and if we escape newlines
610
    # we mangle newlines inside of command blocks.  This assumes that the
611
    # input doesn't contain a pattern which contains actual embedded newlines
612
    # at this point!
613
 
614
    regsub -all {\n} ${user_code} { } subst_code
615
    set subst_code [uplevel list $subst_code]
616
 
617
    set processed_code ""
618
    set patterns ""
619
    set expecting_action 0
620
    set expecting_arg 0
621
    foreach item $user_code subst_item $subst_code {
622
        if { $item == "-n" || $item == "-notransfer" || $item == "-nocase" } {
623
            lappend processed_code $item
624
            continue
625
        }
626
        if { $item == "-indices" || $item == "-re" || $item == "-ex" } {
627
            lappend processed_code $item
628
            continue
629
        }
630
        if { $item == "-timeout" } {
631
            set expecting_arg 1
632
            lappend processed_code $item
633
            continue
634
        }
635
        if { $expecting_arg } {
636
            set expecting_arg 0
637
            lappend processed_code $item
638
            continue
639
        }
640
        if { $expecting_action } {
641
            lappend processed_code "uplevel [list $item]"
642
            set expecting_action 0
643
            # Cosmetic, no effect on the list.
644
            append processed_code "\n"
645
            continue
646
        }
647
        set expecting_action 1
648
        lappend processed_code $subst_item
649
        if {$patterns != ""} {
650
            append patterns "; "
651
        }
652
        append patterns "\"$subst_item\""
653
    }
654
 
655
    # Also purely cosmetic.
656
    regsub -all {\r} $patterns {\\r} patterns
657
    regsub -all {\n} $patterns {\\n} patterns
658
 
659
    if $verbose>2 then {
660
        send_user "Sending \"$command\" to gdb\n"
661
        send_user "Looking to match \"$patterns\"\n"
662
        send_user "Message is \"$message\"\n"
663
    }
664
 
665
    set result -1
666
    set string "${command}\n";
667
    if { $command != "" } {
668
        while { "$string" != "" } {
669
            set foo [string first "\n" "$string"];
670
            set len [string length "$string"];
671
            if { $foo < [expr $len - 1] } {
672
                set str [string range "$string" 0 $foo];
673
                if { [send_gdb "$str"] != "" } {
674
                    global suppress_flag;
675
 
676
                    if { ! $suppress_flag } {
677
                        perror "Couldn't send $command to GDB.";
678
                    }
679
                    fail "$message";
680
                    return $result;
681
                }
682
                # since we're checking if each line of the multi-line
683
                # command are 'accepted' by GDB here,
684
                # we need to set -notransfer expect option so that
685
                # command output is not lost for pattern matching
686
                # - guo
687
                gdb_expect 2 {
688
                    -notransfer -re "\[\r\n\]" { verbose "partial: match" 3 }
689
                    timeout { verbose "partial: timeout" 3 }
690
                }
691
                set string [string range "$string" [expr $foo + 1] end];
692
            } else {
693
                break;
694
            }
695
        }
696
        if { "$string" != "" } {
697
            if { [send_gdb "$string"] != "" } {
698
                global suppress_flag;
699
 
700
                if { ! $suppress_flag } {
701
                    perror "Couldn't send $command to GDB.";
702
                }
703
                fail "$message";
704
                return $result;
705
            }
706
        }
707
    }
708
 
709
    if [target_info exists gdb,timeout] {
710
        set tmt [target_info gdb,timeout];
711
    } else {
712
        if [info exists timeout] {
713
            set tmt $timeout;
714
        } else {
715
            global timeout;
716
            if [info exists timeout] {
717
                set tmt $timeout;
718
            } else {
719
                set tmt 60;
720
            }
721
        }
722
    }
723
 
724
    set code {
725
         -re ".*A problem internal to GDB has been detected" {
726
             fail "$message (GDB internal error)"
727
             gdb_internal_error_resync
728
         }
729
         -re "\\*\\*\\* DOSEXIT code.*" {
730
             if { $message != "" } {
731
                 fail "$message";
732
             }
733
             gdb_suppress_entire_file "GDB died";
734
             set result -1;
735
         }
736
    }
737
    append code $processed_code
738
    append code {
739
         -re "Ending remote debugging.*$gdb_prompt $" {
740
            if ![isnative] then {
741
                warning "Can`t communicate to remote target."
742
            }
743
            gdb_exit
744
            gdb_start
745
            set result -1
746
        }
747
         -re "Undefined\[a-z\]* command:.*$gdb_prompt $" {
748
            perror "Undefined command \"$command\"."
749
            fail "$message"
750
            set result 1
751
        }
752
         -re "Ambiguous command.*$gdb_prompt $" {
753
            perror "\"$command\" is not a unique command name."
754
            fail "$message"
755
            set result 1
756
        }
757
         -re "Program exited with code \[0-9\]+.*$gdb_prompt $" {
758
            if ![string match "" $message] then {
759
                set errmsg "$message (the program exited)"
760
            } else {
761
                set errmsg "$command (the program exited)"
762
            }
763
            fail "$errmsg"
764
            set result -1
765
        }
766
         -re "Program exited normally.*$gdb_prompt $" {
767
            if ![string match "" $message] then {
768
                set errmsg "$message (the program exited)"
769
            } else {
770
                set errmsg "$command (the program exited)"
771
            }
772
            fail "$errmsg"
773
            set result -1
774
        }
775
         -re "The program is not being run.*$gdb_prompt $" {
776
            if ![string match "" $message] then {
777
                set errmsg "$message (the program is no longer running)"
778
            } else {
779
                set errmsg "$command (the program is no longer running)"
780
            }
781
            fail "$errmsg"
782
            set result -1
783
        }
784
         -re "\r\n$gdb_prompt $" {
785
            if ![string match "" $message] then {
786
                fail "$message"
787
            }
788
            set result 1
789
        }
790
         "" {
791
            send_gdb "\n"
792
            perror "Window too small."
793
            fail "$message"
794
            set result -1
795
        }
796
        -re "\\((y or n|y or \\\[n\\\]|\\\[y\\\] or n)\\) " {
797
            send_gdb "n\n"
798
            gdb_expect -re "$gdb_prompt $"
799
            fail "$message (got interactive prompt)"
800
            set result -1
801
        }
802
        -re "\\\[0\\\] cancel\r\n\\\[1\\\] all.*\r\n> $" {
803
            send_gdb "0\n"
804
            gdb_expect -re "$gdb_prompt $"
805
            fail "$message (got breakpoint menu)"
806
            set result -1
807
        }
808
         eof {
809
             perror "Process no longer exists"
810
             if { $message != "" } {
811
                 fail "$message"
812
             }
813
             return -1
814
        }
815
         full_buffer {
816
            perror "internal buffer is full."
817
            fail "$message"
818
            set result -1
819
        }
820
        timeout {
821
            if ![string match "" $message] then {
822
                fail "$message (timeout)"
823
            }
824
            set result 1
825
        }
826
    }
827
 
828
    set result 0
829
    set code [catch {gdb_expect $tmt $code} string]
830
    if {$code == 1} {
831
        global errorInfo errorCode;
832
        return -code error -errorinfo $errorInfo -errorcode $errorCode $string
833
    } elseif {$code == 2} {
834
        return -code return $string
835
    } elseif {$code == 3} {
836
        return
837
    } elseif {$code > 4} {
838
        return -code $code $string
839
    }
840
    return $result
841
}
842
 
843
# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE
844
# Send a command to gdb; test the result.
845
#
846
# COMMAND is the command to execute, send to GDB with send_gdb.  If
847
#   this is the null string no command is sent.
848
# PATTERN is the pattern to match for a PASS, and must NOT include
849
#   the \r\n sequence immediately before the gdb prompt.
850
# MESSAGE is an optional message to be printed.  If this is
851
#   omitted, then the pass/fail messages use the command string as the
852
#   message.  (If this is the empty string, then sometimes we don't
853
#   call pass or fail at all; I don't understand this at all.)
854
# QUESTION is a question GDB may ask in response to COMMAND, like
855
#   "are you sure?"
856
# RESPONSE is the response to send if QUESTION appears.
857
#
858
# Returns:
859
#    1 if the test failed,
860
#    0 if the test passes,
861
#   -1 if there was an internal error.
862
#
863
proc gdb_test { args } {
864
    global verbose
865
    global gdb_prompt
866
    global GDB
867
    upvar timeout timeout
868
 
869
    if [llength $args]>2 then {
870
        set message [lindex $args 2]
871
    } else {
872
        set message [lindex $args 0]
873
    }
874
    set command [lindex $args 0]
875
    set pattern [lindex $args 1]
876
 
877
    if [llength $args]==5 {
878
        set question_string [lindex $args 3];
879
        set response_string [lindex $args 4];
880
    } else {
881
        set question_string "^FOOBAR$"
882
    }
883
 
884
    return [gdb_test_multiple $command $message {
885
        -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" {
886
            if ![string match "" $message] then {
887
                pass "$message"
888
            }
889
        }
890
        -re "(${question_string})$" {
891
            send_gdb "$response_string\n";
892
            exp_continue;
893
        }
894
     }]
895
}
896
 
897
# gdb_test_no_output COMMAND MESSAGE
898
# Send a command to GDB and verify that this command generated no output.
899
#
900
# See gdb_test_multiple for a description of the COMMAND and MESSAGE
901
# parameters.  If MESSAGE is ommitted, then COMMAND will be used as
902
# the message.  (If MESSAGE is the empty string, then sometimes we do not
903
# call pass or fail at all; I don't understand this at all.)
904
 
905
proc gdb_test_no_output { args } {
906
    global gdb_prompt
907
    set command [lindex $args 0]
908
    if [llength $args]>1 then {
909
        set message [lindex $args 1]
910
    } else {
911
        set message $command
912
    }
913
 
914
    set command_regex [string_to_regexp $command]
915
    gdb_test_multiple $command $message {
916
        -re "^$command_regex\r\n$gdb_prompt $" {
917
            if ![string match "" $message] then {
918
                pass "$message"
919
            }
920
        }
921
    }
922
}
923
 
924
 
925
# Test that a command gives an error.  For pass or fail, return
926
# a 1 to indicate that more tests can proceed.  However a timeout
927
# is a serious error, generates a special fail message, and causes
928
# a 0 to be returned to indicate that more tests are likely to fail
929
# as well.
930
 
931
proc test_print_reject { args } {
932
    global gdb_prompt
933
    global verbose
934
 
935
    if [llength $args]==2 then {
936
        set expectthis [lindex $args 1]
937
    } else {
938
        set expectthis "should never match this bogus string"
939
    }
940
    set sendthis [lindex $args 0]
941
    if $verbose>2 then {
942
        send_user "Sending \"$sendthis\" to gdb\n"
943
        send_user "Looking to match \"$expectthis\"\n"
944
    }
945
    send_gdb "$sendthis\n"
946
    #FIXME: Should add timeout as parameter.
947
    gdb_expect {
948
        -re "A .* in expression.*\\.*$gdb_prompt $" {
949
            pass "reject $sendthis"
950
            return 1
951
        }
952
        -re "Invalid syntax in expression.*$gdb_prompt $" {
953
            pass "reject $sendthis"
954
            return 1
955
        }
956
        -re "Junk after end of expression.*$gdb_prompt $" {
957
            pass "reject $sendthis"
958
            return 1
959
        }
960
        -re "Invalid number.*$gdb_prompt $" {
961
            pass "reject $sendthis"
962
            return 1
963
        }
964
        -re "Invalid character constant.*$gdb_prompt $" {
965
            pass "reject $sendthis"
966
            return 1
967
        }
968
        -re "No symbol table is loaded.*$gdb_prompt $" {
969
            pass "reject $sendthis"
970
            return 1
971
        }
972
        -re "No symbol .* in current context.*$gdb_prompt $" {
973
            pass "reject $sendthis"
974
            return 1
975
        }
976
        -re "Unmatched single quote.*$gdb_prompt $" {
977
            pass "reject $sendthis"
978
            return 1
979
        }
980
        -re "A character constant must contain at least one character.*$gdb_prompt $" {
981
            pass "reject $sendthis"
982
            return 1
983
        }
984
        -re "$expectthis.*$gdb_prompt $" {
985
            pass "reject $sendthis"
986
            return 1
987
        }
988
        -re ".*$gdb_prompt $" {
989
            fail "reject $sendthis"
990
            return 1
991
        }
992
        default {
993
            fail "reject $sendthis (eof or timeout)"
994
            return 0
995
        }
996
    }
997
}
998
 
999
# Given an input string, adds backslashes as needed to create a
1000
# regexp that will match the string.
1001
 
1002
proc string_to_regexp {str} {
1003
    set result $str
1004
    regsub -all {[]*+.|()^$\[\\]} $str {\\&} result
1005
    return $result
1006
}
1007
 
1008
# Same as gdb_test, but the second parameter is not a regexp,
1009
# but a string that must match exactly.
1010
 
1011
proc gdb_test_exact { args } {
1012
    upvar timeout timeout
1013
 
1014
    set command [lindex $args 0]
1015
 
1016
    # This applies a special meaning to a null string pattern.  Without
1017
    # this, "$pattern\r\n$gdb_prompt $" will match anything, including error
1018
    # messages from commands that should have no output except a new
1019
    # prompt.  With this, only results of a null string will match a null
1020
    # string pattern.
1021
 
1022
    set pattern [lindex $args 1]
1023
    if [string match $pattern ""] {
1024
        set pattern [string_to_regexp [lindex $args 0]]
1025
    } else {
1026
        set pattern [string_to_regexp [lindex $args 1]]
1027
    }
1028
 
1029
    # It is most natural to write the pattern argument with only
1030
    # embedded \n's, especially if you are trying to avoid Tcl quoting
1031
    # problems.  But gdb_expect really wants to see \r\n in patterns.  So
1032
    # transform the pattern here.  First transform \r\n back to \n, in
1033
    # case some users of gdb_test_exact already do the right thing.
1034
    regsub -all "\r\n" $pattern "\n" pattern
1035
    regsub -all "\n" $pattern "\r\n" pattern
1036
    if [llength $args]==3 then {
1037
        set message [lindex $args 2]
1038
    } else {
1039
        set message $command
1040
    }
1041
 
1042
    return [gdb_test $command $pattern $message]
1043
}
1044
 
1045
# Wrapper around gdb_test_multiple that looks for a list of expected
1046
# output elements, but which can appear in any order.
1047
# CMD is the gdb command.
1048
# NAME is the name of the test.
1049
# ELM_FIND_REGEXP specifies how to partition the output into elements to
1050
# compare.
1051
# ELM_EXTRACT_REGEXP specifies the part of ELM_FIND_REGEXP to compare.
1052
# RESULT_MATCH_LIST is a list of exact matches for each expected element.
1053
# All elements of RESULT_MATCH_LIST must appear for the test to pass.
1054
#
1055
# A typical use of ELM_FIND_REGEXP/ELM_EXTRACT_REGEXP is to extract one line
1056
# of text per element and then strip trailing \r\n's.
1057
# Example:
1058
# gdb_test_list_exact "foo" "bar" \
1059
#     {[^\r\n]+[\r\n]+} \
1060
#     {[^\r\n]+} \
1061
#     { \
1062
#       {expected result 1} \
1063
#       {expected result 2} \
1064
#     }
1065
 
1066
proc gdb_test_list_exact { cmd name elm_find_regexp elm_extract_regexp result_match_list } {
1067
    global gdb_prompt
1068
 
1069
    set matches [lsort $result_match_list]
1070
    set seen {}
1071
    gdb_test_multiple $cmd $name {
1072
        "$cmd\[\r\n\]" { exp_continue }
1073
        -re $elm_find_regexp {
1074
            set str $expect_out(0,string)
1075
            verbose -log "seen: $str" 3
1076
            regexp -- $elm_extract_regexp $str elm_seen
1077
            verbose -log "extracted: $elm_seen" 3
1078
            lappend seen $elm_seen
1079
            exp_continue
1080
        }
1081
        -re "$gdb_prompt $" {
1082
            set failed ""
1083
            foreach got [lsort $seen] have $matches {
1084
                if {![string equal $got $have]} {
1085
                    set failed $have
1086
                    break
1087
                }
1088
            }
1089
            if {[string length $failed] != 0} {
1090
                fail "$name ($failed not found)"
1091
            } else {
1092
                pass $name
1093
            }
1094
        }
1095
    }
1096
}
1097
 
1098
proc gdb_reinitialize_dir { subdir } {
1099
    global gdb_prompt
1100
 
1101
    if [is_remote host] {
1102
        return "";
1103
    }
1104
    send_gdb "dir\n"
1105
    gdb_expect 60 {
1106
        -re "Reinitialize source path to empty.*y or n. " {
1107
            send_gdb "y\n"
1108
            gdb_expect 60 {
1109
                -re "Source directories searched.*$gdb_prompt $" {
1110
                    send_gdb "dir $subdir\n"
1111
                    gdb_expect 60 {
1112
                        -re "Source directories searched.*$gdb_prompt $" {
1113
                            verbose "Dir set to $subdir"
1114
                        }
1115
                        -re "$gdb_prompt $" {
1116
                            perror "Dir \"$subdir\" failed."
1117
                        }
1118
                    }
1119
                }
1120
                -re "$gdb_prompt $" {
1121
                    perror "Dir \"$subdir\" failed."
1122
                }
1123
            }
1124
        }
1125
        -re "$gdb_prompt $" {
1126
            perror "Dir \"$subdir\" failed."
1127
        }
1128
    }
1129
}
1130
 
1131
#
1132
# gdb_exit -- exit the GDB, killing the target program if necessary
1133
#
1134
proc default_gdb_exit {} {
1135
    global GDB
1136
    global INTERNAL_GDBFLAGS GDBFLAGS
1137
    global verbose
1138
    global gdb_spawn_id;
1139
 
1140
    gdb_stop_suppressing_tests;
1141
 
1142
    if ![info exists gdb_spawn_id] {
1143
        return;
1144
    }
1145
 
1146
    verbose "Quitting $GDB $INTERNAL_GDBFLAGS $GDBFLAGS"
1147
 
1148
    if { [is_remote host] && [board_info host exists fileid] } {
1149
        send_gdb "quit\n";
1150
        gdb_expect 10 {
1151
            -re "y or n" {
1152
                send_gdb "y\n";
1153
                exp_continue;
1154
            }
1155
            -re "DOSEXIT code" { }
1156
            default { }
1157
        }
1158
    }
1159
 
1160
    if ![is_remote host] {
1161
        remote_close host;
1162
    }
1163
    unset gdb_spawn_id
1164
}
1165
 
1166
# Load a file into the debugger.
1167
# The return value is 0 for success, -1 for failure.
1168
#
1169
# This procedure also set the global variable GDB_FILE_CMD_DEBUG_INFO
1170
# to one of these values:
1171
#
1172
#   debug    file was loaded successfully and has debug information
1173
#   nodebug  file was loaded successfully and has no debug information
1174
#   fail     file was not loaded
1175
#
1176
# I tried returning this information as part of the return value,
1177
# but ran into a mess because of the many re-implementations of
1178
# gdb_load in config/*.exp.
1179
#
1180
# TODO: gdb.base/sepdebug.exp and gdb.stabs/weird.exp might be able to use
1181
# this if they can get more information set.
1182
 
1183
proc gdb_file_cmd { arg } {
1184
    global gdb_prompt
1185
    global verbose
1186
    global GDB
1187
    global last_loaded_file
1188
 
1189
    set last_loaded_file $arg
1190
 
1191
    # Set whether debug info was found.
1192
    # Default to "fail".
1193
    global gdb_file_cmd_debug_info
1194
    set gdb_file_cmd_debug_info "fail"
1195
 
1196
    if [is_remote host] {
1197
        set arg [remote_download host $arg]
1198
        if { $arg == "" } {
1199
            perror "download failed"
1200
            return -1
1201
        }
1202
    }
1203
 
1204
    # The file command used to kill the remote target.  For the benefit
1205
    # of the testsuite, preserve this behavior.
1206
    send_gdb "kill\n"
1207
    gdb_expect 120 {
1208
        -re "Kill the program being debugged. .y or n. $" {
1209
            send_gdb "y\n"
1210
            verbose "\t\tKilling previous program being debugged"
1211
            exp_continue
1212
        }
1213
        -re "$gdb_prompt $" {
1214
            # OK.
1215
        }
1216
    }
1217
 
1218
    send_gdb "file $arg\n"
1219
    gdb_expect 120 {
1220
        -re "Reading symbols from.*no debugging symbols found.*done.*$gdb_prompt $" {
1221
            verbose "\t\tLoaded $arg into the $GDB with no debugging symbols"
1222
            set gdb_file_cmd_debug_info "nodebug"
1223
            return 0
1224
        }
1225
        -re "Reading symbols from.*done.*$gdb_prompt $" {
1226
            verbose "\t\tLoaded $arg into the $GDB"
1227
            set gdb_file_cmd_debug_info "debug"
1228
            return 0
1229
        }
1230
        -re "Load new symbol table from \".*\".*y or n. $" {
1231
            send_gdb "y\n"
1232
            gdb_expect 120 {
1233
                -re "Reading symbols from.*done.*$gdb_prompt $" {
1234
                    verbose "\t\tLoaded $arg with new symbol table into $GDB"
1235
                    set gdb_file_cmd_debug_info "debug"
1236
                    return 0
1237
                }
1238
                timeout {
1239
                    perror "(timeout) Couldn't load $arg, other program already loaded."
1240
                    return -1
1241
                }
1242
            }
1243
        }
1244
        -re "No such file or directory.*$gdb_prompt $" {
1245
            perror "($arg) No such file or directory"
1246
            return -1
1247
        }
1248
        -re "$gdb_prompt $" {
1249
            perror "couldn't load $arg into $GDB."
1250
            return -1
1251
            }
1252
        timeout {
1253
            perror "couldn't load $arg into $GDB (timed out)."
1254
            return -1
1255
        }
1256
        eof {
1257
            # This is an attempt to detect a core dump, but seems not to
1258
            # work.  Perhaps we need to match .* followed by eof, in which
1259
            # gdb_expect does not seem to have a way to do that.
1260
            perror "couldn't load $arg into $GDB (end of file)."
1261
            return -1
1262
        }
1263
    }
1264
}
1265
 
1266
#
1267
# start gdb -- start gdb running, default procedure
1268
#
1269
# When running over NFS, particularly if running many simultaneous
1270
# tests on different hosts all using the same server, things can
1271
# get really slow.  Give gdb at least 3 minutes to start up.
1272
#
1273
proc default_gdb_start { } {
1274
    global verbose
1275
    global GDB
1276
    global INTERNAL_GDBFLAGS GDBFLAGS
1277
    global gdb_prompt
1278
    global timeout
1279
    global gdb_spawn_id;
1280
    global env
1281
 
1282
    gdb_stop_suppressing_tests;
1283
 
1284
    set env(LC_CTYPE) C
1285
 
1286
    # Don't let a .inputrc file or an existing setting of INPUTRC mess up
1287
    # the test results.  Even if /dev/null doesn't exist on the particular
1288
    # platform, the readline library will use the default setting just by
1289
    # failing to open the file.  OTOH, opening /dev/null successfully will
1290
    # also result in the default settings being used since nothing will be
1291
    # read from this file.
1292
    set env(INPUTRC) "/dev/null"
1293
 
1294
    # The gdb.base/readline.exp arrow key test relies on the standard VT100
1295
    # bindings, so make sure that an appropriate terminal is selected.
1296
    # The same bug doesn't show up if we use ^P / ^N instead.
1297
    set env(TERM) "vt100"
1298
 
1299
    verbose "Spawning $GDB $INTERNAL_GDBFLAGS $GDBFLAGS"
1300
 
1301
    if [info exists gdb_spawn_id] {
1302
        return 0;
1303
    }
1304
 
1305
    if ![is_remote host] {
1306
        if { [which $GDB] == 0 } then {
1307
            perror "$GDB does not exist."
1308
            exit 1
1309
        }
1310
    }
1311
    set res [remote_spawn host "$GDB $INTERNAL_GDBFLAGS $GDBFLAGS [host_info gdb_opts]"];
1312
    if { $res < 0 || $res == "" } {
1313
        perror "Spawning $GDB failed."
1314
        return 1;
1315
    }
1316
    gdb_expect 360 {
1317
        -re "\[\r\n\]$gdb_prompt $" {
1318
            verbose "GDB initialized."
1319
        }
1320
        -re "$gdb_prompt $"     {
1321
            perror "GDB never initialized."
1322
            return -1
1323
        }
1324
        timeout {
1325
            perror "(timeout) GDB never initialized after 10 seconds."
1326
            remote_close host;
1327
            return -1
1328
        }
1329
    }
1330
    set gdb_spawn_id -1;
1331
    # force the height to "unlimited", so no pagers get used
1332
 
1333
    send_gdb "set height 0\n"
1334
    gdb_expect 10 {
1335
        -re "$gdb_prompt $" {
1336
            verbose "Setting height to 0." 2
1337
        }
1338
        timeout {
1339
            warning "Couldn't set the height to 0"
1340
        }
1341
    }
1342
    # force the width to "unlimited", so no wraparound occurs
1343
    send_gdb "set width 0\n"
1344
    gdb_expect 10 {
1345
        -re "$gdb_prompt $" {
1346
            verbose "Setting width to 0." 2
1347
        }
1348
        timeout {
1349
            warning "Couldn't set the width to 0."
1350
        }
1351
    }
1352
    return 0;
1353
}
1354
 
1355
# Examine the output of compilation to determine whether compilation
1356
# failed or not.  If it failed determine whether it is due to missing
1357
# compiler or due to compiler error.  Report pass, fail or unsupported
1358
# as appropriate
1359
 
1360
proc gdb_compile_test {src output} {
1361
    if { $output == "" } {
1362
        pass "compilation [file tail $src]"
1363
    } elseif { [regexp {^[a-zA-Z_0-9]+: Can't find [^ ]+\.$} $output] } {
1364
        unsupported "compilation [file tail $src]"
1365
    } elseif { [regexp {.*: command not found[\r|\n]*$} $output] } {
1366
        unsupported "compilation [file tail $src]"
1367
    } elseif { [regexp {.*: [^\r\n]*compiler not installed[^\r\n]*[\r|\n]*$} $output] } {
1368
        unsupported "compilation [file tail $src]"
1369
    } else {
1370
        verbose -log "compilation failed: $output" 2
1371
        fail "compilation [file tail $src]"
1372
    }
1373
}
1374
 
1375
# Return a 1 for configurations for which we don't even want to try to
1376
# test C++.
1377
 
1378
proc skip_cplus_tests {} {
1379
    if { [istarget "h8300-*-*"] } {
1380
        return 1
1381
    }
1382
 
1383
    # The C++ IO streams are too large for HC11/HC12 and are thus not
1384
    # available.  The gdb C++ tests use them and don't compile.
1385
    if { [istarget "m6811-*-*"] } {
1386
        return 1
1387
    }
1388
    if { [istarget "m6812-*-*"] } {
1389
        return 1
1390
    }
1391
    return 0
1392
}
1393
 
1394
# Return a 1 for configurations for which don't have both C++ and the STL.
1395
 
1396
proc skip_stl_tests {} {
1397
    # Symbian supports the C++ language, but the STL is missing
1398
    # (both headers and libraries).
1399
    if { [istarget "arm*-*-symbianelf*"] } {
1400
        return 1
1401
    }
1402
 
1403
    return [skip_cplus_tests]
1404
}
1405
 
1406
# Return a 1 if I don't even want to try to test FORTRAN.
1407
 
1408
proc skip_fortran_tests {} {
1409
    return 0
1410
}
1411
 
1412
# Return a 1 if I don't even want to try to test ada.
1413
 
1414
proc skip_ada_tests {} {
1415
    return 0
1416
}
1417
 
1418
# Return a 1 if I don't even want to try to test java.
1419
 
1420
proc skip_java_tests {} {
1421
    return 0
1422
}
1423
 
1424
# Return a 1 for configurations that do not support Python scripting.
1425
 
1426
proc skip_python_tests {} {
1427
    global gdb_prompt
1428
    gdb_test_multiple "python print 'test'" "verify python support" {
1429
        -re "not supported.*$gdb_prompt $"      {
1430
            unsupported "Python support is disabled."
1431
            return 1
1432
        }
1433
        -re "$gdb_prompt $"     {}
1434
    }
1435
 
1436
    return 0
1437
}
1438
 
1439
# Return a 1 if we should skip shared library tests.
1440
 
1441
proc skip_shlib_tests {} {
1442
    # Run the shared library tests on native systems.
1443
    if {[isnative]} {
1444
        return 0
1445
    }
1446
 
1447
    # An abbreviated list of remote targets where we should be able to
1448
    # run shared library tests.
1449
    if {([istarget *-*-linux*]
1450
         || [istarget *-*-*bsd*]
1451
         || [istarget *-*-solaris2*]
1452
         || [istarget arm*-*-symbianelf*]
1453
         || [istarget *-*-mingw*]
1454
         || [istarget *-*-cygwin*]
1455
         || [istarget *-*-pe*])} {
1456
        return 0
1457
    }
1458
 
1459
    return 1
1460
}
1461
 
1462
# Run a test on the target to see if it supports vmx hardware.  Return 0 if so,
1463
# 1 if it does not.  Based on 'check_vmx_hw_available' from the GCC testsuite.
1464
 
1465
proc skip_altivec_tests {} {
1466
    global skip_vmx_tests_saved
1467
    global srcdir subdir gdb_prompt
1468
 
1469
    # Use the cached value, if it exists.
1470
    set me "skip_altivec_tests"
1471
    if [info exists skip_vmx_tests_saved] {
1472
        verbose "$me:  returning saved $skip_vmx_tests_saved" 2
1473
        return $skip_vmx_tests_saved
1474
    }
1475
 
1476
    # Some simulators are known to not support VMX instructions.
1477
    if { [istarget powerpc-*-eabi] || [istarget powerpc*-*-eabispe] } {
1478
        verbose "$me:  target known to not support VMX, returning 1" 2
1479
        return [set skip_vmx_tests_saved 1]
1480
    }
1481
 
1482
    # Make sure we have a compiler that understands altivec.
1483
    set compile_flags {debug nowarnings}
1484
    if [get_compiler_info not-used] {
1485
       warning "Could not get compiler info"
1486
       return 1
1487
    }
1488
    if [test_compiler_info gcc*] {
1489
        set compile_flags "$compile_flags additional_flags=-maltivec"
1490
    } elseif [test_compiler_info xlc*] {
1491
        set compile_flags "$compile_flags additional_flags=-qaltivec"
1492
    } else {
1493
        verbose "Could not compile with altivec support, returning 1" 2
1494
        return 1
1495
    }
1496
 
1497
    # Set up, compile, and execute a test program containing VMX instructions.
1498
    # Include the current process ID in the file names to prevent conflicts
1499
    # with invocations for multiple testsuites.
1500
    set src vmx[pid].c
1501
    set exe vmx[pid].x
1502
 
1503
    set f [open $src "w"]
1504
    puts $f "int main() {"
1505
    puts $f "#ifdef __MACH__"
1506
    puts $f "  asm volatile (\"vor v0,v0,v0\");"
1507
    puts $f "#else"
1508
    puts $f "  asm volatile (\"vor 0,0,0\");"
1509
    puts $f "#endif"
1510
    puts $f "  return 0; }"
1511
    close $f
1512
 
1513
    verbose "$me:  compiling testfile $src" 2
1514
    set lines [gdb_compile $src $exe executable $compile_flags]
1515
    file delete $src
1516
 
1517
    if ![string match "" $lines] then {
1518
        verbose "$me:  testfile compilation failed, returning 1" 2
1519
        return [set skip_vmx_tests_saved 1]
1520
    }
1521
 
1522
    # No error message, compilation succeeded so now run it via gdb.
1523
 
1524
    gdb_exit
1525
    gdb_start
1526
    gdb_reinitialize_dir $srcdir/$subdir
1527
    gdb_load "$exe"
1528
    gdb_run_cmd
1529
    gdb_expect {
1530
        -re ".*Illegal instruction.*${gdb_prompt} $" {
1531
            verbose -log "\n$me altivec hardware not detected"
1532
            set skip_vmx_tests_saved 1
1533
        }
1534
        -re ".*Program exited normally.*${gdb_prompt} $" {
1535
            verbose -log "\n$me: altivec hardware detected"
1536
            set skip_vmx_tests_saved 0
1537
        }
1538
        default {
1539
          warning "\n$me: default case taken"
1540
            set skip_vmx_tests_saved 1
1541
        }
1542
    }
1543
    gdb_exit
1544
    remote_file build delete $exe
1545
 
1546
    verbose "$me:  returning $skip_vmx_tests_saved" 2
1547
    return $skip_vmx_tests_saved
1548
}
1549
 
1550
# Run a test on the target to see if it supports vmx hardware.  Return 0 if so,
1551
# 1 if it does not.  Based on 'check_vmx_hw_available' from the GCC testsuite.
1552
 
1553
proc skip_vsx_tests {} {
1554
    global skip_vsx_tests_saved
1555
    global srcdir subdir gdb_prompt
1556
 
1557
    # Use the cached value, if it exists.
1558
    set me "skip_vsx_tests"
1559
    if [info exists skip_vsx_tests_saved] {
1560
        verbose "$me:  returning saved $skip_vsx_tests_saved" 2
1561
        return $skip_vsx_tests_saved
1562
    }
1563
 
1564
    # Some simulators are known to not support Altivec instructions, so
1565
    # they won't support VSX instructions as well.
1566
    if { [istarget powerpc-*-eabi] || [istarget powerpc*-*-eabispe] } {
1567
        verbose "$me:  target known to not support VSX, returning 1" 2
1568
        return [set skip_vsx_tests_saved 1]
1569
    }
1570
 
1571
    # Make sure we have a compiler that understands altivec.
1572
    set compile_flags {debug nowarnings quiet}
1573
    if [get_compiler_info not-used] {
1574
       warning "Could not get compiler info"
1575
       return 1
1576
    }
1577
    if [test_compiler_info gcc*] {
1578
        set compile_flags "$compile_flags additional_flags=-mvsx"
1579
    } elseif [test_compiler_info xlc*] {
1580
        set compile_flags "$compile_flags additional_flags=-qvsx"
1581
    } else {
1582
        verbose "Could not compile with vsx support, returning 1" 2
1583
        return 1
1584
    }
1585
 
1586
    set src vsx[pid].c
1587
    set exe vsx[pid].x
1588
 
1589
    set f [open $src "w"]
1590
    puts $f "int main() {"
1591
    puts $f "#ifdef __MACH__"
1592
    puts $f "  asm volatile (\"lxvd2x v0,v0,v0\");"
1593
    puts $f "#else"
1594
    puts $f "  asm volatile (\"lxvd2x 0,0,0\");"
1595
    puts $f "#endif"
1596
    puts $f "  return 0; }"
1597
    close $f
1598
 
1599
    verbose "$me:  compiling testfile $src" 2
1600
    set lines [gdb_compile $src $exe executable $compile_flags]
1601
    file delete $src
1602
 
1603
    if ![string match "" $lines] then {
1604
        verbose "$me:  testfile compilation failed, returning 1" 2
1605
        return [set skip_vsx_tests_saved 1]
1606
    }
1607
 
1608
    # No error message, compilation succeeded so now run it via gdb.
1609
 
1610
    gdb_exit
1611
    gdb_start
1612
    gdb_reinitialize_dir $srcdir/$subdir
1613
    gdb_load "$exe"
1614
    gdb_run_cmd
1615
    gdb_expect {
1616
        -re ".*Illegal instruction.*${gdb_prompt} $" {
1617
            verbose -log "\n$me VSX hardware not detected"
1618
            set skip_vsx_tests_saved 1
1619
        }
1620
        -re ".*Program exited normally.*${gdb_prompt} $" {
1621
            verbose -log "\n$me: VSX hardware detected"
1622
            set skip_vsx_tests_saved 0
1623
        }
1624
        default {
1625
          warning "\n$me: default case taken"
1626
            set skip_vsx_tests_saved 1
1627
        }
1628
    }
1629
    gdb_exit
1630
    remote_file build delete $exe
1631
 
1632
    verbose "$me:  returning $skip_vsx_tests_saved" 2
1633
    return $skip_vsx_tests_saved
1634
}
1635
 
1636
# Skip all the tests in the file if you are not on an hppa running
1637
# hpux target.
1638
 
1639
proc skip_hp_tests {} {
1640
    eval set skip_hp [ expr ![isnative] || ![istarget "hppa*-*-hpux*"] ]
1641
    verbose "Skip hp tests is $skip_hp"
1642
    return $skip_hp
1643
}
1644
 
1645
# Return whether we should skip tests for showing inlined functions in
1646
# backtraces.  Requires get_compiler_info and get_debug_format.
1647
 
1648
proc skip_inline_frame_tests {} {
1649
    # GDB only recognizes inlining information in DWARF 2 (DWARF 3).
1650
    if { ! [test_debug_format "DWARF 2"] } {
1651
        return 1
1652
    }
1653
 
1654
    # GCC before 4.1 does not emit DW_AT_call_file / DW_AT_call_line.
1655
    if { ([test_compiler_info "gcc-2-*"]
1656
          || [test_compiler_info "gcc-3-*"]
1657
          || [test_compiler_info "gcc-4-0-*"]) } {
1658
        return 1
1659
    }
1660
 
1661
    return 0
1662
}
1663
 
1664
# Return whether we should skip tests for showing variables from
1665
# inlined functions.  Requires get_compiler_info and get_debug_format.
1666
 
1667
proc skip_inline_var_tests {} {
1668
    # GDB only recognizes inlining information in DWARF 2 (DWARF 3).
1669
    if { ! [test_debug_format "DWARF 2"] } {
1670
        return 1
1671
    }
1672
 
1673
    return 0
1674
}
1675
 
1676
set compiler_info               "unknown"
1677
set gcc_compiled                0
1678
set hp_cc_compiler              0
1679
set hp_aCC_compiler             0
1680
 
1681
# Figure out what compiler I am using.
1682
#
1683
# BINFILE is a "compiler information" output file.  This implementation
1684
# does not use BINFILE.
1685
#
1686
# ARGS can be empty or "C++".  If empty, "C" is assumed.
1687
#
1688
# There are several ways to do this, with various problems.
1689
#
1690
# [ gdb_compile -E $ifile -o $binfile.ci ]
1691
# source $binfile.ci
1692
#
1693
#   Single Unix Spec v3 says that "-E -o ..." together are not
1694
#   specified.  And in fact, the native compiler on hp-ux 11 (among
1695
#   others) does not work with "-E -o ...".  Most targets used to do
1696
#   this, and it mostly worked, because it works with gcc.
1697
#
1698
# [ catch "exec $compiler -E $ifile > $binfile.ci" exec_output ]
1699
# source $binfile.ci
1700
#
1701
#   This avoids the problem with -E and -o together.  This almost works
1702
#   if the build machine is the same as the host machine, which is
1703
#   usually true of the targets which are not gcc.  But this code does
1704
#   not figure which compiler to call, and it always ends up using the C
1705
#   compiler.  Not good for setting hp_aCC_compiler.  Targets
1706
#   hppa*-*-hpux* and mips*-*-irix* used to do this.
1707
#
1708
# [ gdb_compile -E $ifile > $binfile.ci ]
1709
# source $binfile.ci
1710
#
1711
#   dejagnu target_compile says that it supports output redirection,
1712
#   but the code is completely different from the normal path and I
1713
#   don't want to sweep the mines from that path.  So I didn't even try
1714
#   this.
1715
#
1716
# set cppout [ gdb_compile $ifile "" preprocess $args quiet ]
1717
# eval $cppout
1718
#
1719
#   I actually do this for all targets now.  gdb_compile runs the right
1720
#   compiler, and TCL captures the output, and I eval the output.
1721
#
1722
#   Unfortunately, expect logs the output of the command as it goes by,
1723
#   and dejagnu helpfully prints a second copy of it right afterwards.
1724
#   So I turn off expect logging for a moment.
1725
#
1726
# [ gdb_compile $ifile $ciexe_file executable $args ]
1727
# [ remote_exec $ciexe_file ]
1728
# [ source $ci_file.out ]
1729
#
1730
#   I could give up on -E and just do this.
1731
#   I didn't get desperate enough to try this.
1732
#
1733
# -- chastain 2004-01-06
1734
 
1735
proc get_compiler_info {binfile args} {
1736
    # For compiler.c and compiler.cc
1737
    global srcdir
1738
 
1739
    # I am going to play with the log to keep noise out.
1740
    global outdir
1741
    global tool
1742
 
1743
    # These come from compiler.c or compiler.cc
1744
    global compiler_info
1745
 
1746
    # Legacy global data symbols.
1747
    global gcc_compiled
1748
    global hp_cc_compiler
1749
    global hp_aCC_compiler
1750
 
1751
    # Choose which file to preprocess.
1752
    set ifile "${srcdir}/lib/compiler.c"
1753
    if { [llength $args] > 0 && [lindex $args 0] == "c++" } {
1754
        set ifile "${srcdir}/lib/compiler.cc"
1755
    }
1756
 
1757
    # Run $ifile through the right preprocessor.
1758
    # Toggle gdb.log to keep the compiler output out of the log.
1759
    log_file
1760
    if [is_remote host] {
1761
        # We have to use -E and -o together, despite the comments
1762
        # above, because of how DejaGnu handles remote host testing.
1763
        set ppout "$outdir/compiler.i"
1764
        gdb_compile "${ifile}" "$ppout" preprocess [list "$args" quiet]
1765
        set file [open $ppout r]
1766
        set cppout [read $file]
1767
        close $file
1768
    } else {
1769
        set cppout [ gdb_compile "${ifile}" "" preprocess [list "$args" quiet] ]
1770
    }
1771
    log_file -a "$outdir/$tool.log"
1772
 
1773
    # Eval the output.
1774
    set unknown 0
1775
    foreach cppline [ split "$cppout" "\n" ] {
1776
        if { [ regexp "^#" "$cppline" ] } {
1777
            # line marker
1778
        } elseif { [ regexp "^\[\n\r\t \]*$" "$cppline" ] } {
1779
            # blank line
1780
        } elseif { [ regexp "^\[\n\r\t \]*set\[\n\r\t \]" "$cppline" ] } {
1781
            # eval this line
1782
            verbose "get_compiler_info: $cppline" 2
1783
            eval "$cppline"
1784
        } else {
1785
            # unknown line
1786
            verbose -log "get_compiler_info: $cppline"
1787
            set unknown 1
1788
        }
1789
    }
1790
 
1791
    # Reset to unknown compiler if any diagnostics happened.
1792
    if { $unknown } {
1793
        set compiler_info "unknown"
1794
    }
1795
 
1796
    # Set the legacy symbols.
1797
    set gcc_compiled     0
1798
    set hp_cc_compiler   0
1799
    set hp_aCC_compiler  0
1800
    if { [regexp "^gcc-1-" "$compiler_info" ] } { set gcc_compiled 1 }
1801
    if { [regexp "^gcc-2-" "$compiler_info" ] } { set gcc_compiled 2 }
1802
    if { [regexp "^gcc-3-" "$compiler_info" ] } { set gcc_compiled 3 }
1803
    if { [regexp "^gcc-4-" "$compiler_info" ] } { set gcc_compiled 4 }
1804
    if { [regexp "^gcc-5-" "$compiler_info" ] } { set gcc_compiled 5 }
1805
    if { [regexp "^hpcc-"  "$compiler_info" ] } { set hp_cc_compiler 1 }
1806
    if { [regexp "^hpacc-" "$compiler_info" ] } { set hp_aCC_compiler 1 }
1807
 
1808
    # Log what happened.
1809
    verbose -log "get_compiler_info: $compiler_info"
1810
 
1811
    # Most compilers will evaluate comparisons and other boolean
1812
    # operations to 0 or 1.
1813
    uplevel \#0 { set true 1 }
1814
    uplevel \#0 { set false 0 }
1815
 
1816
    # Use of aCC results in boolean results being displayed as
1817
    # "true" or "false"
1818
    if { $hp_aCC_compiler } {
1819
      uplevel \#0 { set true true }
1820
      uplevel \#0 { set false false }
1821
    }
1822
 
1823
    return 0;
1824
}
1825
 
1826
proc test_compiler_info { {compiler ""} } {
1827
    global compiler_info
1828
 
1829
     # if no arg, return the compiler_info string
1830
 
1831
     if [string match "" $compiler] {
1832
         if [info exists compiler_info] {
1833
             return $compiler_info
1834
         } else {
1835
             perror "No compiler info found."
1836
         }
1837
     }
1838
 
1839
    return [string match $compiler $compiler_info]
1840
}
1841
 
1842
proc current_target_name { } {
1843
    global target_info
1844
    if [info exists target_info(target,name)] {
1845
        set answer $target_info(target,name)
1846
    } else {
1847
        set answer ""
1848
    }
1849
    return $answer
1850
}
1851
 
1852
set gdb_wrapper_initialized 0
1853
set gdb_wrapper_target ""
1854
 
1855
proc gdb_wrapper_init { args } {
1856
    global gdb_wrapper_initialized;
1857
    global gdb_wrapper_file;
1858
    global gdb_wrapper_flags;
1859
    global gdb_wrapper_target
1860
 
1861
    if { $gdb_wrapper_initialized == 1 } { return; }
1862
 
1863
    if {[target_info exists needs_status_wrapper] && \
1864
            [target_info needs_status_wrapper] != "0"} {
1865
        set result [build_wrapper "testglue.o"];
1866
        if { $result != "" } {
1867
            set gdb_wrapper_file [lindex $result 0];
1868
            set gdb_wrapper_flags [lindex $result 1];
1869
        } else {
1870
            warning "Status wrapper failed to build."
1871
        }
1872
    }
1873
    set gdb_wrapper_initialized 1
1874
    set gdb_wrapper_target [current_target_name]
1875
}
1876
 
1877
# Some targets need to always link a special object in.  Save its path here.
1878
global gdb_saved_set_unbuffered_mode_obj
1879
set gdb_saved_set_unbuffered_mode_obj ""
1880
 
1881
proc gdb_compile {source dest type options} {
1882
    global GDB_TESTCASE_OPTIONS;
1883
    global gdb_wrapper_file;
1884
    global gdb_wrapper_flags;
1885
    global gdb_wrapper_initialized;
1886
    global srcdir
1887
    global objdir
1888
    global gdb_saved_set_unbuffered_mode_obj
1889
 
1890
    set outdir [file dirname $dest]
1891
 
1892
    # Add platform-specific options if a shared library was specified using
1893
    # "shlib=librarypath" in OPTIONS.
1894
    set new_options ""
1895
    set shlib_found 0
1896
    set shlib_load 0
1897
    foreach opt $options {
1898
        if [regexp {^shlib=(.*)} $opt dummy_var shlib_name] {
1899
            if [test_compiler_info "xlc-*"] {
1900
                # IBM xlc compiler doesn't accept shared library named other
1901
                # than .so: use "-Wl," to bypass this
1902
                lappend source "-Wl,$shlib_name"
1903
            } elseif { ([istarget "*-*-mingw*"]
1904
                        || [istarget *-*-cygwin*]
1905
                        || [istarget *-*-pe*])} {
1906
                lappend source "${shlib_name}.a"
1907
            } else {
1908
               lappend source $shlib_name
1909
            }
1910
            if { $shlib_found == 0 } {
1911
                set shlib_found 1
1912
                if { ([istarget "*-*-mingw*"]
1913
                      || [istarget *-*-cygwin*]) } {
1914
                    lappend new_options "additional_flags=-Wl,--enable-auto-import"
1915
                }
1916
            }
1917
        } elseif { $opt == "shlib_load" } {
1918
            set shlib_load 1
1919
        } else {
1920
            lappend new_options $opt
1921
        }
1922
    }
1923
 
1924
    # We typically link to shared libraries using an absolute path, and
1925
    # that's how they are found at runtime.  If we are going to
1926
    # dynamically load one by basename, we must specify rpath.  If we
1927
    # are using a remote host, DejaGNU will link to the shared library
1928
    # using a relative path, so again we must specify an rpath.
1929
    if { $shlib_load || ($shlib_found && [is_remote host]) } {
1930
        if { ([istarget "*-*-mingw*"]
1931
              || [istarget *-*-cygwin*]
1932
              || [istarget *-*-pe*]
1933
              || [istarget hppa*-*-hpux*])} {
1934
            # Do not need anything.
1935
        } elseif { [istarget *-*-openbsd*] } {
1936
            lappend new_options "additional_flags=-Wl,-rpath,${outdir}"
1937
        } elseif { [istarget arm*-*-symbianelf*] } {
1938
            if { $shlib_load } {
1939
                lappend new_options "libs=-ldl"
1940
            }
1941
        } else {
1942
            if { $shlib_load } {
1943
                lappend new_options "libs=-ldl"
1944
            }
1945
            lappend new_options "additional_flags=-Wl,-rpath,\\\$ORIGIN"
1946
        }
1947
    }
1948
    set options $new_options
1949
 
1950
    if [target_info exists gdb_stub] {
1951
        set options2 { "additional_flags=-Dusestubs" }
1952
        lappend options "libs=[target_info gdb_stub]";
1953
        set options [concat $options2 $options]
1954
    }
1955
    if [target_info exists is_vxworks] {
1956
        set options2 { "additional_flags=-Dvxworks" }
1957
        lappend options "libs=[target_info gdb_stub]";
1958
        set options [concat $options2 $options]
1959
    }
1960
    if [info exists GDB_TESTCASE_OPTIONS] {
1961
        lappend options "additional_flags=$GDB_TESTCASE_OPTIONS";
1962
    }
1963
    verbose "options are $options"
1964
    verbose "source is $source $dest $type $options"
1965
 
1966
    if { $gdb_wrapper_initialized == 0 } { gdb_wrapper_init }
1967
 
1968
    if {[target_info exists needs_status_wrapper] && \
1969
            [target_info needs_status_wrapper] != "0" && \
1970
            [info exists gdb_wrapper_file]} {
1971
        lappend options "libs=${gdb_wrapper_file}"
1972
        lappend options "ldflags=${gdb_wrapper_flags}"
1973
    }
1974
 
1975
    # Replace the "nowarnings" option with the appropriate additional_flags
1976
    # to disable compiler warnings.
1977
    set nowarnings [lsearch -exact $options nowarnings]
1978
    if {$nowarnings != -1} {
1979
        if [target_info exists gdb,nowarnings_flag] {
1980
            set flag "additional_flags=[target_info gdb,nowarnings_flag]"
1981
        } else {
1982
            set flag "additional_flags=-w"
1983
        }
1984
        set options [lreplace $options $nowarnings $nowarnings $flag]
1985
    }
1986
 
1987
    if { $type == "executable" } {
1988
        if { ([istarget "*-*-mingw*"]
1989
              || [istarget "*-*-*djgpp"]
1990
              || [istarget "*-*-cygwin*"])} {
1991
            # Force output to unbuffered mode, by linking in an object file
1992
            # with a global contructor that calls setvbuf.
1993
            #
1994
            # Compile the special object seperatelly for two reasons:
1995
            #  1) Insulate it from $options.
1996
            #  2) Avoid compiling it for every gdb_compile invocation,
1997
            #  which is time consuming, especially if we're remote
1998
            #  host testing.
1999
            #
2000
            if { $gdb_saved_set_unbuffered_mode_obj == "" } {
2001
                verbose "compiling gdb_saved_set_unbuffered_obj"
2002
                set unbuf_src ${srcdir}/lib/set_unbuffered_mode.c
2003
                set unbuf_obj ${objdir}/set_unbuffered_mode.o
2004
 
2005
                set result [gdb_compile "${unbuf_src}" "${unbuf_obj}" object {nowarnings}]
2006
                if { $result != "" } {
2007
                    return $result
2008
                }
2009
 
2010
                set gdb_saved_set_unbuffered_mode_obj ${objdir}/set_unbuffered_mode_saved.o
2011
                # Link a copy of the output object, because the
2012
                # original may be automatically deleted.
2013
                remote_exec host "cp -f $unbuf_obj $gdb_saved_set_unbuffered_mode_obj"
2014
            } else {
2015
                verbose "gdb_saved_set_unbuffered_obj already compiled"
2016
            }
2017
 
2018
            # Rely on the internal knowledge that the global ctors are ran in
2019
            # reverse link order.  In that case, we can use ldflags to
2020
            # avoid copying the object file to the host multiple
2021
            # times.
2022
            # This object can only be added if standard libraries are
2023
            # used. Thus, we need to disable it if -nostdlib option is used
2024
            if {[lsearch -regexp $options "-nostdlib"] < 0 } {
2025
                lappend options "ldflags=$gdb_saved_set_unbuffered_mode_obj"
2026
            }
2027
        }
2028
    }
2029
 
2030
    set result [target_compile $source $dest $type $options];
2031
 
2032
    # Prune uninteresting compiler (and linker) output.
2033
    regsub "Creating library file: \[^\r\n\]*\[\r\n\]+" $result "" result
2034
 
2035
    regsub "\[\r\n\]*$" "$result" "" result;
2036
    regsub "^\[\r\n\]*" "$result" "" result;
2037
 
2038
    if {[lsearch $options quiet] < 0} {
2039
        # We shall update this on a per language basis, to avoid
2040
        # changing the entire testsuite in one go.
2041
        if {[lsearch $options f77] >= 0} {
2042
            gdb_compile_test $source $result
2043
        } elseif { $result != "" } {
2044
            clone_output "gdb compile failed, $result"
2045
        }
2046
    }
2047
    return $result;
2048
}
2049
 
2050
 
2051
# This is just like gdb_compile, above, except that it tries compiling
2052
# against several different thread libraries, to see which one this
2053
# system has.
2054
proc gdb_compile_pthreads {source dest type options} {
2055
    set built_binfile 0
2056
    set why_msg "unrecognized error"
2057
    foreach lib {-lpthreads -lpthread -lthread ""} {
2058
        # This kind of wipes out whatever libs the caller may have
2059
        # set.  Or maybe theirs will override ours.  How infelicitous.
2060
        set options_with_lib [concat $options [list libs=$lib quiet]]
2061
        set ccout [gdb_compile $source $dest $type $options_with_lib]
2062
        switch -regexp -- $ccout {
2063
            ".*no posix threads support.*" {
2064
                set why_msg "missing threads include file"
2065
                break
2066
            }
2067
            ".*cannot open -lpthread.*" {
2068
                set why_msg "missing runtime threads library"
2069
            }
2070
            ".*Can't find library for -lpthread.*" {
2071
                set why_msg "missing runtime threads library"
2072
            }
2073
            {^$} {
2074
                pass "successfully compiled posix threads test case"
2075
                set built_binfile 1
2076
                break
2077
            }
2078
        }
2079
    }
2080
    if {!$built_binfile} {
2081
        unsupported "Couldn't compile $source: ${why_msg}"
2082
        return -1
2083
    }
2084
}
2085
 
2086
# Build a shared library from SOURCES.  You must use get_compiler_info
2087
# first.
2088
 
2089
proc gdb_compile_shlib {sources dest options} {
2090
    set obj_options $options
2091
 
2092
    switch -glob [test_compiler_info] {
2093
        "xlc-*" {
2094
            lappend obj_options "additional_flags=-qpic"
2095
        }
2096
        "gcc-*" {
2097
            if { !([istarget "powerpc*-*-aix*"]
2098
                   || [istarget "rs6000*-*-aix*"]
2099
                   || [istarget "*-*-cygwin*"]
2100
                   || [istarget "*-*-mingw*"]
2101
                   || [istarget "*-*-pe*"]) } {
2102
                lappend obj_options "additional_flags=-fpic"
2103
            }
2104
        }
2105
        default {
2106
            switch -glob [istarget] {
2107
                "hppa*-hp-hpux*" {
2108
                    lappend obj_options "additional_flags=+z"
2109
                }
2110
                "mips-sgi-irix*" {
2111
                    # Disable SGI compiler's implicit -Dsgi
2112
                    lappend obj_options "additional_flags=-Usgi"
2113
                }
2114
                default {
2115
                    # don't know what the compiler is...
2116
                }
2117
            }
2118
        }
2119
    }
2120
 
2121
    set outdir [file dirname $dest]
2122
    set objects ""
2123
    foreach source $sources {
2124
       set sourcebase [file tail $source]
2125
       if {[gdb_compile $source "${outdir}/${sourcebase}.o" object $obj_options] != ""} {
2126
           return -1
2127
       }
2128
       lappend objects ${outdir}/${sourcebase}.o
2129
    }
2130
 
2131
    if [istarget "hppa*-*-hpux*"] {
2132
       remote_exec build "ld -b ${objects} -o ${dest}"
2133
    } else {
2134
       set link_options $options
2135
       if [test_compiler_info "xlc-*"] {
2136
          lappend link_options "additional_flags=-qmkshrobj"
2137
       } else {
2138
          lappend link_options "additional_flags=-shared"
2139
 
2140
           if { ([istarget "*-*-mingw*"]
2141
                 || [istarget *-*-cygwin*]
2142
                 || [istarget *-*-pe*])} {
2143
               lappend link_options "additional_flags=-Wl,--out-implib,${dest}.a"
2144
           }
2145
       }
2146
       if {[gdb_compile "${objects}" "${dest}" executable $link_options] != ""} {
2147
           return -1
2148
       }
2149
    }
2150
}
2151
 
2152
# This is just like gdb_compile_pthreads, above, except that we always add the
2153
# objc library for compiling Objective-C programs
2154
proc gdb_compile_objc {source dest type options} {
2155
    set built_binfile 0
2156
    set why_msg "unrecognized error"
2157
    foreach lib {-lobjc -lpthreads -lpthread -lthread solaris} {
2158
        # This kind of wipes out whatever libs the caller may have
2159
        # set.  Or maybe theirs will override ours.  How infelicitous.
2160
        if { $lib == "solaris" } {
2161
            set lib "-lpthread -lposix4"
2162
        }
2163
        if { $lib != "-lobjc" } {
2164
          set lib "-lobjc $lib"
2165
        }
2166
        set options_with_lib [concat $options [list libs=$lib quiet]]
2167
        set ccout [gdb_compile $source $dest $type $options_with_lib]
2168
        switch -regexp -- $ccout {
2169
            ".*no posix threads support.*" {
2170
                set why_msg "missing threads include file"
2171
                break
2172
            }
2173
            ".*cannot open -lpthread.*" {
2174
                set why_msg "missing runtime threads library"
2175
            }
2176
            ".*Can't find library for -lpthread.*" {
2177
                set why_msg "missing runtime threads library"
2178
            }
2179
            {^$} {
2180
                pass "successfully compiled objc with posix threads test case"
2181
                set built_binfile 1
2182
                break
2183
            }
2184
        }
2185
    }
2186
    if {!$built_binfile} {
2187
        unsupported "Couldn't compile $source: ${why_msg}"
2188
        return -1
2189
    }
2190
}
2191
 
2192
proc send_gdb { string } {
2193
    global suppress_flag;
2194
    if { $suppress_flag } {
2195
        return "suppressed";
2196
    }
2197
    return [remote_send host "$string"];
2198
}
2199
 
2200
#
2201
#
2202
 
2203
proc gdb_expect { args } {
2204
    if { [llength $args] == 2  && [lindex $args 0] != "-re" } {
2205
        set atimeout [lindex $args 0];
2206
        set expcode [list [lindex $args 1]];
2207
    } else {
2208
        set expcode $args;
2209
    }
2210
 
2211
    upvar timeout timeout;
2212
 
2213
    if [target_info exists gdb,timeout] {
2214
        if [info exists timeout] {
2215
            if { $timeout < [target_info gdb,timeout] } {
2216
                set gtimeout [target_info gdb,timeout];
2217
            } else {
2218
                set gtimeout $timeout;
2219
            }
2220
        } else {
2221
            set gtimeout [target_info gdb,timeout];
2222
        }
2223
    }
2224
 
2225
    if ![info exists gtimeout] {
2226
        global timeout;
2227
        if [info exists timeout] {
2228
            set gtimeout $timeout;
2229
        }
2230
    }
2231
 
2232
    if [info exists atimeout] {
2233
        if { ![info exists gtimeout] || $gtimeout < $atimeout } {
2234
            set gtimeout $atimeout;
2235
        }
2236
    } else {
2237
        if ![info exists gtimeout] {
2238
            # Eeeeew.
2239
            set gtimeout 60;
2240
        }
2241
    }
2242
 
2243
    global suppress_flag;
2244
    global remote_suppress_flag;
2245
    if [info exists remote_suppress_flag] {
2246
        set old_val $remote_suppress_flag;
2247
    }
2248
    if [info exists suppress_flag] {
2249
        if { $suppress_flag } {
2250
            set remote_suppress_flag 1;
2251
        }
2252
    }
2253
    set code [catch \
2254
        {uplevel remote_expect host $gtimeout $expcode} string];
2255
    if [info exists old_val] {
2256
        set remote_suppress_flag $old_val;
2257
    } else {
2258
        if [info exists remote_suppress_flag] {
2259
            unset remote_suppress_flag;
2260
        }
2261
    }
2262
 
2263
    if {$code == 1} {
2264
        global errorInfo errorCode;
2265
 
2266
        return -code error -errorinfo $errorInfo -errorcode $errorCode $string
2267
    } elseif {$code == 2} {
2268
        return -code return $string
2269
    } elseif {$code == 3} {
2270
        return
2271
    } elseif {$code > 4} {
2272
        return -code $code $string
2273
    }
2274
}
2275
 
2276
# gdb_expect_list MESSAGE SENTINEL LIST -- expect a sequence of outputs
2277
#
2278
# Check for long sequence of output by parts.
2279
# MESSAGE: is the test message to be printed with the test success/fail.
2280
# SENTINEL: Is the terminal pattern indicating that output has finished.
2281
# LIST: is the sequence of outputs to match.
2282
# If the sentinel is recognized early, it is considered an error.
2283
#
2284
# Returns:
2285
#    1 if the test failed,
2286
#    0 if the test passes,
2287
#   -1 if there was an internal error.
2288
#
2289
proc gdb_expect_list {test sentinel list} {
2290
    global gdb_prompt
2291
    global suppress_flag
2292
    set index 0
2293
    set ok 1
2294
    if { $suppress_flag } {
2295
        set ok 0
2296
        unresolved "${test}"
2297
    }
2298
    while { ${index} < [llength ${list}] } {
2299
        set pattern [lindex ${list} ${index}]
2300
        set index [expr ${index} + 1]
2301
        if { ${index} == [llength ${list}] } {
2302
            if { ${ok} } {
2303
                gdb_expect {
2304
                    -re "${pattern}${sentinel}" {
2305
                        # pass "${test}, pattern ${index} + sentinel"
2306
                    }
2307
                    -re "${sentinel}" {
2308
                        fail "${test} (pattern ${index} + sentinel)"
2309
                        set ok 0
2310
                    }
2311
                    -re ".*A problem internal to GDB has been detected" {
2312
                        fail "${test} (GDB internal error)"
2313
                        set ok 0
2314
                        gdb_internal_error_resync
2315
                    }
2316
                    timeout {
2317
                        fail "${test} (pattern ${index} + sentinel) (timeout)"
2318
                        set ok 0
2319
                    }
2320
                }
2321
            } else {
2322
                # unresolved "${test}, pattern ${index} + sentinel"
2323
            }
2324
        } else {
2325
            if { ${ok} } {
2326
                gdb_expect {
2327
                    -re "${pattern}" {
2328
                        # pass "${test}, pattern ${index}"
2329
                    }
2330
                    -re "${sentinel}" {
2331
                        fail "${test} (pattern ${index})"
2332
                        set ok 0
2333
                    }
2334
                    -re ".*A problem internal to GDB has been detected" {
2335
                        fail "${test} (GDB internal error)"
2336
                        set ok 0
2337
                        gdb_internal_error_resync
2338
                    }
2339
                    timeout {
2340
                        fail "${test} (pattern ${index}) (timeout)"
2341
                        set ok 0
2342
                    }
2343
                }
2344
            } else {
2345
                # unresolved "${test}, pattern ${index}"
2346
            }
2347
        }
2348
    }
2349
    if { ${ok} } {
2350
        pass "${test}"
2351
        return 0
2352
    } else {
2353
        return 1
2354
    }
2355
}
2356
 
2357
#
2358
#
2359
proc gdb_suppress_entire_file { reason } {
2360
    global suppress_flag;
2361
 
2362
    warning "$reason\n";
2363
    set suppress_flag -1;
2364
}
2365
 
2366
#
2367
# Set suppress_flag, which will cause all subsequent calls to send_gdb and
2368
# gdb_expect to fail immediately (until the next call to
2369
# gdb_stop_suppressing_tests).
2370
#
2371
proc gdb_suppress_tests { args } {
2372
    global suppress_flag;
2373
 
2374
    return;  # fnf - disable pending review of results where
2375
             # testsuite ran better without this
2376
    incr suppress_flag;
2377
 
2378
    if { $suppress_flag == 1 } {
2379
        if { [llength $args] > 0 } {
2380
            warning "[lindex $args 0]\n";
2381
        } else {
2382
            warning "Because of previous failure, all subsequent tests in this group will automatically fail.\n";
2383
        }
2384
    }
2385
}
2386
 
2387
#
2388
# Clear suppress_flag.
2389
#
2390
proc gdb_stop_suppressing_tests { } {
2391
    global suppress_flag;
2392
 
2393
    if [info exists suppress_flag] {
2394
        if { $suppress_flag > 0 } {
2395
            set suppress_flag 0;
2396
            clone_output "Tests restarted.\n";
2397
        }
2398
    } else {
2399
        set suppress_flag 0;
2400
    }
2401
}
2402
 
2403
proc gdb_clear_suppressed { } {
2404
    global suppress_flag;
2405
 
2406
    set suppress_flag 0;
2407
}
2408
 
2409
proc gdb_start { } {
2410
    default_gdb_start
2411
}
2412
 
2413
proc gdb_exit { } {
2414
    catch default_gdb_exit
2415
}
2416
 
2417
#
2418
# gdb_load_cmd -- load a file into the debugger.
2419
#                 ARGS - additional args to load command.
2420
#                 return a -1 if anything goes wrong.
2421
#
2422
proc gdb_load_cmd { args } {
2423
    global gdb_prompt
2424
 
2425
    if [target_info exists gdb_load_timeout] {
2426
        set loadtimeout [target_info gdb_load_timeout]
2427
    } else {
2428
        set loadtimeout 1600
2429
    }
2430
    send_gdb "load $args\n"
2431
    verbose "Timeout is now $loadtimeout seconds" 2
2432
    gdb_expect $loadtimeout {
2433
        -re "Loading section\[^\r\]*\r\n" {
2434
            exp_continue
2435
        }
2436
        -re "Start address\[\r\]*\r\n" {
2437
            exp_continue
2438
        }
2439
        -re "Transfer rate\[\r\]*\r\n" {
2440
            exp_continue
2441
        }
2442
        -re "Memory access error\[^\r\]*\r\n" {
2443
            perror "Failed to load program"
2444
            return -1
2445
        }
2446
        -re "$gdb_prompt $" {
2447
            return 0
2448
        }
2449
        -re "(.*)\r\n$gdb_prompt " {
2450
            perror "Unexpected reponse from 'load' -- $expect_out(1,string)"
2451
            return -1
2452
        }
2453
        timeout {
2454
            perror "Timed out trying to load $args."
2455
            return -1
2456
        }
2457
    }
2458
    return -1
2459
}
2460
 
2461
# Return the filename to download to the target and load on the target
2462
# for this shared library.  Normally just LIBNAME, unless shared libraries
2463
# for this target have separate link and load images.
2464
 
2465
proc shlib_target_file { libname } {
2466
    return $libname
2467
}
2468
 
2469
# Return the filename GDB will load symbols from when debugging this
2470
# shared library.  Normally just LIBNAME, unless shared libraries for
2471
# this target have separate link and load images.
2472
 
2473
proc shlib_symbol_file { libname } {
2474
    return $libname
2475
}
2476
 
2477
# gdb_download
2478
#
2479
# Copy a file to the remote target and return its target filename.
2480
# Schedule the file to be deleted at the end of this test.
2481
 
2482
proc gdb_download { filename } {
2483
    global cleanfiles
2484
 
2485
    set destname [remote_download target $filename]
2486
    lappend cleanfiles $destname
2487
    return $destname
2488
}
2489
 
2490
# gdb_load_shlibs LIB...
2491
#
2492
# Copy the listed libraries to the target.
2493
 
2494
proc gdb_load_shlibs { args } {
2495
    if {![is_remote target]} {
2496
        return
2497
    }
2498
 
2499
    foreach file $args {
2500
        gdb_download [shlib_target_file $file]
2501
    }
2502
 
2503
    # Even if the target supplies full paths for shared libraries,
2504
    # they may not be paths for this system.
2505
    gdb_test "set solib-search-path [file dirname [lindex $args 0]]" "" ""
2506
}
2507
 
2508
#
2509
# gdb_load -- load a file into the debugger.
2510
# Many files in config/*.exp override this procedure.
2511
#
2512
proc gdb_load { arg } {
2513
    return [gdb_file_cmd $arg]
2514
}
2515
 
2516
# gdb_reload -- load a file into the target.  Called before "running",
2517
# either the first time or after already starting the program once,
2518
# for remote targets.  Most files that override gdb_load should now
2519
# override this instead.
2520
 
2521
proc gdb_reload { } {
2522
    # For the benefit of existing configurations, default to gdb_load.
2523
    # Specifying no file defaults to the executable currently being
2524
    # debugged.
2525
    return [gdb_load ""]
2526
}
2527
 
2528
proc gdb_continue { function } {
2529
    global decimal
2530
 
2531
    return [gdb_test "continue" ".*Breakpoint $decimal, $function .*" "continue to $function"];
2532
}
2533
 
2534
proc default_gdb_init { args } {
2535
    global gdb_wrapper_initialized
2536
    global gdb_wrapper_target
2537
    global cleanfiles
2538
 
2539
    set cleanfiles {}
2540
 
2541
    gdb_clear_suppressed;
2542
 
2543
    # Make sure that the wrapper is rebuilt
2544
    # with the appropriate multilib option.
2545
    if { $gdb_wrapper_target != [current_target_name] } {
2546
        set gdb_wrapper_initialized 0
2547
    }
2548
 
2549
    # Unlike most tests, we have a small number of tests that generate
2550
    # a very large amount of output.  We therefore increase the expect
2551
    # buffer size to be able to contain the entire test output.
2552
    match_max -d 30000
2553
    # Also set this value for the currently running GDB.
2554
    match_max [match_max -d]
2555
 
2556
    # We want to add the name of the TCL testcase to the PASS/FAIL messages.
2557
    if { [llength $args] > 0 } {
2558
        global pf_prefix
2559
 
2560
        set file [lindex $args 0];
2561
 
2562
        set pf_prefix "[file tail [file dirname $file]]/[file tail $file]:";
2563
    }
2564
    global gdb_prompt;
2565
    if [target_info exists gdb_prompt] {
2566
        set gdb_prompt [target_info gdb_prompt];
2567
    } else {
2568
        set gdb_prompt "\\(gdb\\)"
2569
    }
2570
}
2571
 
2572
# The default timeout used when testing GDB commands.  We want to use
2573
# the same timeout as the default dejagnu timeout, unless the user has
2574
# already provided a specific value (probably through a site.exp file).
2575
global gdb_test_timeout
2576
if ![info exists gdb_test_timeout] {
2577
    set gdb_test_timeout $timeout
2578
}
2579
 
2580
# A list of global variables that GDB testcases should not use.
2581
# We try to prevent their use by monitoring write accesses and raising
2582
# an error when that happens.
2583
set banned_variables { bug_id prms_id }
2584
 
2585
# gdb_init is called by runtest at start, but also by several
2586
# tests directly; gdb_finish is only called from within runtest after
2587
# each test source execution.
2588
# Placing several traces by repetitive calls to gdb_init leads
2589
# to problems, as only one trace is removed in gdb_finish.
2590
# To overcome this possible problem, we add a variable that records
2591
# if the banned variables are traced.
2592
set banned_variables_traced 0
2593
 
2594
proc gdb_init { args } {
2595
    # Reset the timeout value to the default.  This way, any testcase
2596
    # that changes the timeout value without resetting it cannot affect
2597
    # the timeout used in subsequent testcases.
2598
    global gdb_test_timeout
2599
    global timeout
2600
    set timeout $gdb_test_timeout
2601
 
2602
    # Block writes to all banned variables...
2603
    global banned_variables
2604
    global banned_variables_traced
2605
    if (!$banned_variables_traced) {
2606
        foreach banned_var $banned_variables {
2607
            global "$banned_var"
2608
            trace add variable "$banned_var" write error
2609
        }
2610
        set banned_variables_traced 1
2611
    }
2612
 
2613
    return [eval default_gdb_init $args];
2614
}
2615
 
2616
proc gdb_finish { } {
2617
    global cleanfiles
2618
 
2619
    # Exit first, so that the files are no longer in use.
2620
    gdb_exit
2621
 
2622
    if { [llength $cleanfiles] > 0 } {
2623
        eval remote_file target delete $cleanfiles
2624
        set cleanfiles {}
2625
    }
2626
 
2627
    # Unblock write access to the banned variables.  Dejagnu typically
2628
    # resets some of them between testcases.
2629
    global banned_variables
2630
    global banned_variables_traced
2631
    if ($banned_variables_traced) {
2632
        foreach banned_var $banned_variables {
2633
            global "$banned_var"
2634
            trace remove variable "$banned_var" write error
2635
        }
2636
        set banned_variables_traced 0
2637
    }
2638
}
2639
 
2640
global debug_format
2641
set debug_format "unknown"
2642
 
2643
# Run the gdb command "info source" and extract the debugging format
2644
# information from the output and save it in debug_format.
2645
 
2646
proc get_debug_format { } {
2647
    global gdb_prompt
2648
    global verbose
2649
    global expect_out
2650
    global debug_format
2651
 
2652
    set debug_format "unknown"
2653
    send_gdb "info source\n"
2654
    gdb_expect 10 {
2655
        -re "Compiled with (.*) debugging format.\r\n.*$gdb_prompt $" {
2656
            set debug_format $expect_out(1,string)
2657
            verbose "debug format is $debug_format"
2658
            return 1;
2659
        }
2660
        -re "No current source file.\r\n$gdb_prompt $" {
2661
            perror "get_debug_format used when no current source file"
2662
            return 0;
2663
        }
2664
        -re "$gdb_prompt $" {
2665
            warning "couldn't check debug format (no valid response)."
2666
            return 1;
2667
        }
2668
        timeout {
2669
            warning "couldn't check debug format (timed out)."
2670
            return 1;
2671
        }
2672
    }
2673
}
2674
 
2675
# Return true if FORMAT matches the debug format the current test was
2676
# compiled with.  FORMAT is a shell-style globbing pattern; it can use
2677
# `*', `[...]', and so on.
2678
#
2679
# This function depends on variables set by `get_debug_format', above.
2680
 
2681
proc test_debug_format {format} {
2682
    global debug_format
2683
 
2684
    return [expr [string match $format $debug_format] != 0]
2685
}
2686
 
2687
# Like setup_xfail, but takes the name of a debug format (DWARF 1,
2688
# COFF, stabs, etc).  If that format matches the format that the
2689
# current test was compiled with, then the next test is expected to
2690
# fail for any target.  Returns 1 if the next test or set of tests is
2691
# expected to fail, 0 otherwise (or if it is unknown).  Must have
2692
# previously called get_debug_format.
2693
proc setup_xfail_format { format } {
2694
    set ret [test_debug_format $format];
2695
 
2696
    if {$ret} then {
2697
        setup_xfail "*-*-*"
2698
    }
2699
    return $ret;
2700
}
2701
 
2702
proc gdb_step_for_stub { } {
2703
    global gdb_prompt;
2704
 
2705
    if ![target_info exists gdb,use_breakpoint_for_stub] {
2706
        if [target_info exists gdb_stub_step_command] {
2707
            set command [target_info gdb_stub_step_command];
2708
        } else {
2709
            set command "step";
2710
        }
2711
        send_gdb "${command}\n";
2712
        set tries 0;
2713
        gdb_expect 60 {
2714
            -re "(main.* at |.*in .*start).*$gdb_prompt" {
2715
                return;
2716
            }
2717
            -re ".*$gdb_prompt" {
2718
                incr tries;
2719
                if { $tries == 5 } {
2720
                    fail "stepping out of breakpoint function";
2721
                    return;
2722
                }
2723
                send_gdb "${command}\n";
2724
                exp_continue;
2725
            }
2726
            default {
2727
                fail "stepping out of breakpoint function";
2728
                return;
2729
            }
2730
        }
2731
    }
2732
    send_gdb "where\n";
2733
    gdb_expect {
2734
        -re "main\[^\r\n\]*at \(\[^:]+\):\(\[0-9\]+\)" {
2735
            set file $expect_out(1,string);
2736
            set linenum [expr $expect_out(2,string) + 1];
2737
            set breakplace "${file}:${linenum}";
2738
        }
2739
        default {}
2740
    }
2741
    send_gdb "break ${breakplace}\n";
2742
    gdb_expect 60 {
2743
        -re "Breakpoint (\[0-9\]+) at.*$gdb_prompt" {
2744
            set breakpoint $expect_out(1,string);
2745
        }
2746
        -re "Breakpoint (\[0-9\]+): file.*$gdb_prompt" {
2747
            set breakpoint $expect_out(1,string);
2748
        }
2749
        default {}
2750
    }
2751
    send_gdb "continue\n";
2752
    gdb_expect 60 {
2753
        -re "Breakpoint ${breakpoint},.*$gdb_prompt" {
2754
            gdb_test "delete $breakpoint" ".*" "";
2755
            return;
2756
        }
2757
        default {}
2758
    }
2759
}
2760
 
2761
# gdb_get_line_number TEXT [FILE]
2762
#
2763
# Search the source file FILE, and return the line number of the
2764
# first line containing TEXT.  If no match is found, return -1.
2765
#
2766
# TEXT is a string literal, not a regular expression.
2767
#
2768
# The default value of FILE is "$srcdir/$subdir/$srcfile".  If FILE is
2769
# specified, and does not start with "/", then it is assumed to be in
2770
# "$srcdir/$subdir".  This is awkward, and can be fixed in the future,
2771
# by changing the callers and the interface at the same time.
2772
# In particular: gdb.base/break.exp, gdb.base/condbreak.exp,
2773
# gdb.base/ena-dis-br.exp.
2774
#
2775
# Use this function to keep your test scripts independent of the
2776
# exact line numbering of the source file.  Don't write:
2777
#
2778
#   send_gdb "break 20"
2779
#
2780
# This means that if anyone ever edits your test's source file,
2781
# your test could break.  Instead, put a comment like this on the
2782
# source file line you want to break at:
2783
#
2784
#   /* breakpoint spot: frotz.exp: test name */
2785
#
2786
# and then write, in your test script (which we assume is named
2787
# frotz.exp):
2788
#
2789
#   send_gdb "break [gdb_get_line_number "frotz.exp: test name"]\n"
2790
#
2791
# (Yes, Tcl knows how to handle the nested quotes and brackets.
2792
# Try this:
2793
#       $ tclsh
2794
#       % puts "foo [lindex "bar baz" 1]"
2795
#       foo baz
2796
#       %
2797
# Tcl is quite clever, for a little stringy language.)
2798
#
2799
# ===
2800
#
2801
# The previous implementation of this procedure used the gdb search command.
2802
# This version is different:
2803
#
2804
#   . It works with MI, and it also works when gdb is not running.
2805
#
2806
#   . It operates on the build machine, not the host machine.
2807
#
2808
#   . For now, this implementation fakes a current directory of
2809
#     $srcdir/$subdir to be compatible with the old implementation.
2810
#     This will go away eventually and some callers will need to
2811
#     be changed.
2812
#
2813
#   . The TEXT argument is literal text and matches literally,
2814
#     not a regular expression as it was before.
2815
#
2816
#   . State changes in gdb, such as changing the current file
2817
#     and setting $_, no longer happen.
2818
#
2819
# After a bit of time we can forget about the differences from the
2820
# old implementation.
2821
#
2822
# --chastain 2004-08-05
2823
 
2824
proc gdb_get_line_number { text { file "" } } {
2825
    global srcdir
2826
    global subdir
2827
    global srcfile
2828
 
2829
    if { "$file" == "" } then {
2830
        set file "$srcfile"
2831
    }
2832
    if { ! [regexp "^/" "$file"] } then {
2833
        set file "$srcdir/$subdir/$file"
2834
    }
2835
 
2836
    if { [ catch { set fd [open "$file"] } message ] } then {
2837
        perror "$message"
2838
        return -1
2839
    }
2840
 
2841
    set found -1
2842
    for { set line 1 } { 1 } { incr line } {
2843
        if { [ catch { set nchar [gets "$fd" body] } message ] } then {
2844
            perror "$message"
2845
            return -1
2846
        }
2847
        if { $nchar < 0 } then {
2848
            break
2849
        }
2850
        if { [string first "$text" "$body"] >= 0 } then {
2851
            set found $line
2852
            break
2853
        }
2854
    }
2855
 
2856
    if { [ catch { close "$fd" } message ] } then {
2857
        perror "$message"
2858
        return -1
2859
    }
2860
 
2861
    return $found
2862
}
2863
 
2864
# gdb_continue_to_end:
2865
#       The case where the target uses stubs has to be handled specially. If a
2866
#       stub is used, we set a breakpoint at exit because we cannot rely on
2867
#       exit() behavior of a remote target.
2868
#
2869
# mssg is the error message that gets printed.
2870
 
2871
proc gdb_continue_to_end {mssg} {
2872
  if [target_info exists use_gdb_stub] {
2873
    if {![gdb_breakpoint "exit"]} {
2874
      return 0
2875
    }
2876
    gdb_test "continue" "Continuing..*Breakpoint .*exit.*" \
2877
      "continue until exit at $mssg"
2878
  } else {
2879
    # Continue until we exit.  Should not stop again.
2880
    # Don't bother to check the output of the program, that may be
2881
    # extremely tough for some remote systems.
2882
    gdb_test "continue"\
2883
      "Continuing.\[\r\n0-9\]+(... EXIT code 0\[\r\n\]+|Program exited normally\\.).*"\
2884
      "continue until exit at $mssg"
2885
  }
2886
}
2887
 
2888
proc rerun_to_main {} {
2889
  global gdb_prompt
2890
 
2891
  if [target_info exists use_gdb_stub] {
2892
    gdb_run_cmd
2893
    gdb_expect {
2894
      -re ".*Breakpoint .*main .*$gdb_prompt $"\
2895
              {pass "rerun to main" ; return 0}
2896
      -re "$gdb_prompt $"\
2897
              {fail "rerun to main" ; return 0}
2898
      timeout {fail "(timeout) rerun to main" ; return 0}
2899
    }
2900
  } else {
2901
    send_gdb "run\n"
2902
    gdb_expect {
2903
      -re "The program .* has been started already.*y or n. $" {
2904
          send_gdb "y\n"
2905
          exp_continue
2906
      }
2907
      -re "Starting program.*$gdb_prompt $"\
2908
              {pass "rerun to main" ; return 0}
2909
      -re "$gdb_prompt $"\
2910
              {fail "rerun to main" ; return 0}
2911
      timeout {fail "(timeout) rerun to main" ; return 0}
2912
    }
2913
  }
2914
}
2915
 
2916
# Print a message and return true if a test should be skipped
2917
# due to lack of floating point suport.
2918
 
2919
proc gdb_skip_float_test { msg } {
2920
    if [target_info exists gdb,skip_float_tests] {
2921
        verbose "Skipping test '$msg': no float tests.";
2922
        return 1;
2923
    }
2924
    return 0;
2925
}
2926
 
2927
# Print a message and return true if a test should be skipped
2928
# due to lack of stdio support.
2929
 
2930
proc gdb_skip_stdio_test { msg } {
2931
    if [target_info exists gdb,noinferiorio] {
2932
        verbose "Skipping test '$msg': no inferior i/o.";
2933
        return 1;
2934
    }
2935
    return 0;
2936
}
2937
 
2938
proc gdb_skip_bogus_test { msg } {
2939
    return 0;
2940
}
2941
 
2942
# Return true if a test should be skipped due to lack of XML support
2943
# in the host GDB.
2944
# NOTE: This must be called while gdb is *not* running.
2945
 
2946
proc gdb_skip_xml_test { } {
2947
    global gdb_prompt
2948
    global srcdir
2949
    global xml_missing_cached
2950
 
2951
    if {[info exists xml_missing_cached]} {
2952
        return $xml_missing_cached
2953
    }
2954
 
2955
    gdb_start
2956
    set xml_missing_cached 0
2957
    gdb_test_multiple "set tdesc filename ${srcdir}/gdb.xml/trivial.xml" "" {
2958
        -re ".*XML support was disabled at compile time.*$gdb_prompt $" {
2959
            set xml_missing_cached 1
2960
        }
2961
        -re ".*$gdb_prompt $" { }
2962
    }
2963
    gdb_exit
2964
    return $xml_missing_cached
2965
}
2966
 
2967
# Note: the procedure gdb_gnu_strip_debug will produce an executable called
2968
# ${binfile}.dbglnk, which is just like the executable ($binfile) but without
2969
# the debuginfo. Instead $binfile has a .gnu_debuglink section which contains
2970
# the name of a debuginfo only file. This file will be stored in the same
2971
# subdirectory.
2972
 
2973
# Functions for separate debug info testing
2974
 
2975
# starting with an executable:
2976
# foo --> original executable
2977
 
2978
# at the end of the process we have:
2979
# foo.stripped --> foo w/o debug info
2980
# foo.debug --> foo's debug info
2981
# foo --> like foo, but with a new .gnu_debuglink section pointing to foo.debug.
2982
 
2983
# Return the build-id hex string (usually 160 bits as 40 hex characters)
2984
# converted to the form: .build-id/ab/cdef1234...89.debug
2985
# Return "" if no build-id found.
2986
proc build_id_debug_filename_get { exec } {
2987
    set tmp "${exec}-tmp"
2988
    set objcopy_program [transform objcopy]
2989
 
2990
    set result [catch "exec $objcopy_program -j .note.gnu.build-id -O binary $exec $tmp" output]
2991
    verbose "result is $result"
2992
    verbose "output is $output"
2993
    if {$result == 1} {
2994
        return ""
2995
    }
2996
    set fi [open $tmp]
2997
    fconfigure $fi -translation binary
2998
    # Skip the NOTE header.
2999
    read $fi 16
3000
    set data [read $fi]
3001
    close $fi
3002
    file delete $tmp
3003
    if ![string compare $data ""] then {
3004
        return ""
3005
    }
3006
    # Convert it to hex.
3007
    binary scan $data H* data
3008
    regsub {^..} $data {\0/} data
3009
    return ".build-id/${data}.debug";
3010
}
3011
 
3012
# Create stripped files for DEST, replacing it.  If ARGS is passed, it is a
3013
# list of optional flags.  The only currently supported flag is no-main,
3014
# which removes the symbol entry for main from the separate debug file.
3015
#
3016
# Function returns zero on success.  Function will return non-zero failure code
3017
# on some targets not supporting separate debug info (such as i386-msdos).
3018
 
3019
proc gdb_gnu_strip_debug { dest args } {
3020
 
3021
    # Use the first separate debug info file location searched by GDB so the
3022
    # run cannot be broken by some stale file searched with higher precedence.
3023
    set debug_file "${dest}.debug"
3024
 
3025
    set strip_to_file_program [transform strip]
3026
    set objcopy_program [transform objcopy]
3027
 
3028
    set debug_link [file tail $debug_file]
3029
    set stripped_file "${dest}.stripped"
3030
 
3031
    # Get rid of the debug info, and store result in stripped_file
3032
    # something like gdb/testsuite/gdb.base/blah.stripped.
3033
    set result [catch "exec $strip_to_file_program --strip-debug ${dest} -o ${stripped_file}" output]
3034
    verbose "result is $result"
3035
    verbose "output is $output"
3036
    if {$result == 1} {
3037
      return 1
3038
    }
3039
 
3040
    # Workaround PR binutils/10802:
3041
    # Preserve the 'x' bit also for PIEs (Position Independent Executables).
3042
    set perm [file attributes ${dest} -permissions]
3043
    file attributes ${stripped_file} -permissions $perm
3044
 
3045
    # Get rid of everything but the debug info, and store result in debug_file
3046
    # This will be in the .debug subdirectory, see above.
3047
    set result [catch "exec $strip_to_file_program --only-keep-debug ${dest} -o ${debug_file}" output]
3048
    verbose "result is $result"
3049
    verbose "output is $output"
3050
    if {$result == 1} {
3051
      return 1
3052
    }
3053
 
3054
    # If no-main is passed, strip the symbol for main from the separate
3055
    # file.  This is to simulate the behavior of elfutils's eu-strip, which
3056
    # leaves the symtab in the original file only.  There's no way to get
3057
    # objcopy or strip to remove the symbol table without also removing the
3058
    # debugging sections, so this is as close as we can get.
3059
    if { [llength $args] == 1 && [lindex $args 0] == "no-main" } {
3060
        set result [catch "exec $objcopy_program -N main ${debug_file} ${debug_file}-tmp" output]
3061
        verbose "result is $result"
3062
        verbose "output is $output"
3063
        if {$result == 1} {
3064
            return 1
3065
        }
3066
        file delete "${debug_file}"
3067
        file rename "${debug_file}-tmp" "${debug_file}"
3068
    }
3069
 
3070
    # Link the two previous output files together, adding the .gnu_debuglink
3071
    # section to the stripped_file, containing a pointer to the debug_file,
3072
    # save the new file in dest.
3073
    # This will be the regular executable filename, in the usual location.
3074
    set result [catch "exec $objcopy_program --add-gnu-debuglink=${debug_file} ${stripped_file} ${dest}" output]
3075
    verbose "result is $result"
3076
    verbose "output is $output"
3077
    if {$result == 1} {
3078
      return 1
3079
    }
3080
 
3081
    # Workaround PR binutils/10802:
3082
    # Preserve the 'x' bit also for PIEs (Position Independent Executables).
3083
    set perm [file attributes ${stripped_file} -permissions]
3084
    file attributes ${dest} -permissions $perm
3085
 
3086
    return 0
3087
}
3088
 
3089
# Test the output of GDB_COMMAND matches the pattern obtained
3090
# by concatenating all elements of EXPECTED_LINES.  This makes
3091
# it possible to split otherwise very long string into pieces.
3092
# If third argument is not empty, it's used as the name of the
3093
# test to be printed on pass/fail.
3094
proc help_test_raw { gdb_command expected_lines args } {
3095
    set message $gdb_command
3096
    if [llength $args]>0 then {
3097
        set message [lindex $args 0]
3098
    }
3099
    set expected_output [join $expected_lines ""]
3100
    gdb_test "${gdb_command}" "${expected_output}" $message
3101
}
3102
 
3103
# Test the output of "help COMMNAD_CLASS". EXPECTED_INITIAL_LINES
3104
# are regular expressions that should match the beginning of output,
3105
# before the list of commands in that class.  The presence of
3106
# command list and standard epilogue will be tested automatically.
3107
proc test_class_help { command_class expected_initial_lines args } {
3108
    set l_stock_body {
3109
        "List of commands\:.*\[\r\n\]+"
3110
        "Type \"help\" followed by command name for full documentation\.\[\r\n\]+"
3111
        "Type \"apropos word\" to search for commands related to \"word\"\.[\r\n\]+"
3112
        "Command name abbreviations are allowed if unambiguous\."
3113
    }
3114
    set l_entire_body [concat $expected_initial_lines $l_stock_body]
3115
 
3116
    eval [list help_test_raw "help ${command_class}" $l_entire_body] $args
3117
}
3118
 
3119
# COMMAND_LIST should have either one element -- command to test, or
3120
# two elements -- abbreviated command to test, and full command the first
3121
# element is abbreviation of.
3122
# The command must be a prefix command.  EXPECTED_INITIAL_LINES
3123
# are regular expressions that should match the beginning of output,
3124
# before the list of subcommands.  The presence of
3125
# subcommand list and standard epilogue will be tested automatically.
3126
proc test_prefix_command_help { command_list expected_initial_lines args } {
3127
    set command [lindex $command_list 0]
3128
    if {[llength $command_list]>1} {
3129
        set full_command [lindex $command_list 1]
3130
    } else {
3131
        set full_command $command
3132
    }
3133
    # Use 'list' and not just {} because we want variables to
3134
    # be expanded in this list.
3135
    set l_stock_body [list\
3136
         "List of $full_command subcommands\:.*\[\r\n\]+"\
3137
         "Type \"help $full_command\" followed by $full_command subcommand name for full documentation\.\[\r\n\]+"\
3138
         "Type \"apropos word\" to search for commands related to \"word\"\.\[\r\n\]+"\
3139
         "Command name abbreviations are allowed if unambiguous\."]
3140
    set l_entire_body [concat $expected_initial_lines $l_stock_body]
3141
    if {[llength $args]>0} {
3142
        help_test_raw "help ${command}" $l_entire_body [lindex $args 0]
3143
    } else {
3144
        help_test_raw "help ${command}" $l_entire_body
3145
    }
3146
}
3147
 
3148
# Build executable named EXECUTABLE, from SOURCES.  If SOURCES are not
3149
# provided, uses $EXECUTABLE.c.  The TESTNAME paramer is the name of test
3150
# to pass to untested, if something is wrong.  OPTIONS are passed
3151
# to gdb_compile directly.
3152
proc build_executable { testname executable {sources ""} {options {debug}} } {
3153
 
3154
    global objdir
3155
    global subdir
3156
    global srcdir
3157
    if {[llength $sources]==0} {
3158
        set sources ${executable}.c
3159
    }
3160
 
3161
    set binfile ${objdir}/${subdir}/${executable}
3162
 
3163
    set objects {}
3164
    for {set i 0} "\$i<[llength $sources]" {incr i} {
3165
        set s [lindex $sources $i]
3166
        if  { [gdb_compile "${srcdir}/${subdir}/${s}" "${binfile}${i}.o" object $options] != "" } {
3167
            untested $testname
3168
            return -1
3169
        }
3170
        lappend objects "${binfile}${i}.o"
3171
    }
3172
 
3173
    if  { [gdb_compile $objects "${binfile}" executable $options] != "" } {
3174
        untested $testname
3175
        return -1
3176
    }
3177
 
3178
    if [get_compiler_info ${binfile}] {
3179
        return -1
3180
    }
3181
    return 0
3182
}
3183
 
3184
# Starts fresh GDB binary and loads EXECUTABLE into GDB. EXECUTABLE is
3185
# the name of binary in ${objdir}/${subdir}.
3186
proc clean_restart { executable } {
3187
    global srcdir
3188
    global objdir
3189
    global subdir
3190
    set binfile ${objdir}/${subdir}/${executable}
3191
 
3192
    gdb_exit
3193
    gdb_start
3194
    gdb_reinitialize_dir $srcdir/$subdir
3195
    gdb_load ${binfile}
3196
 
3197
    if [target_info exists gdb_stub] {
3198
        gdb_step_for_stub;
3199
    }
3200
}
3201
 
3202
# Prepares for testing, by calling build_executable, and then clean_restart.
3203
# Please refer to build_executable for parameter description.
3204
proc prepare_for_testing { testname executable {sources ""} {options {debug}}} {
3205
 
3206
    if {[build_executable $testname $executable $sources $options] == -1} {
3207
        return -1
3208
    }
3209
    clean_restart $executable
3210
 
3211
    return 0
3212
}
3213
 
3214
proc get_valueof { fmt exp default } {
3215
    global gdb_prompt
3216
 
3217
    set test "get valueof \"${exp}\""
3218
    set val ${default}
3219
    gdb_test_multiple "print${fmt} ${exp}" "$test" {
3220
        -re "\\$\[0-9\]* = (.*)\[\r\n\]*$gdb_prompt $" {
3221
            set val $expect_out(1,string)
3222
            pass "$test ($val)"
3223
        }
3224
        timeout {
3225
            fail "$test (timeout)"
3226
        }
3227
    }
3228
    return ${val}
3229
}
3230
 
3231
proc get_integer_valueof { exp default } {
3232
    global gdb_prompt
3233
 
3234
    set test "get integer valueof \"${exp}\""
3235
    set val ${default}
3236
    gdb_test_multiple "print /d ${exp}" "$test" {
3237
        -re "\\$\[0-9\]* = (\[-\]*\[0-9\]*).*$gdb_prompt $" {
3238
            set val $expect_out(1,string)
3239
            pass "$test ($val)"
3240
        }
3241
        timeout {
3242
            fail "$test (timeout)"
3243
        }
3244
    }
3245
    return ${val}
3246
}
3247
 
3248
proc get_hexadecimal_valueof { exp default } {
3249
    global gdb_prompt
3250
    send_gdb "print /x ${exp}\n"
3251
    set test "get hexadecimal valueof \"${exp}\""
3252
    gdb_expect {
3253
        -re "\\$\[0-9\]* = (0x\[0-9a-zA-Z\]+).*$gdb_prompt $" {
3254
            set val $expect_out(1,string)
3255
            pass "$test"
3256
        }
3257
        timeout {
3258
            set val ${default}
3259
            fail "$test (timeout)"
3260
        }
3261
    }
3262
    return ${val}
3263
}
3264
 
3265
proc get_sizeof { type default } {
3266
    return [get_integer_valueof "sizeof (${type})" $default]
3267
}
3268
 
3269
# Log gdb command line and script if requested.
3270
if {[info exists TRANSCRIPT]} {
3271
  rename send_gdb real_send_gdb
3272
  rename remote_spawn real_remote_spawn
3273
  rename remote_close real_remote_close
3274
 
3275
  global gdb_transcript
3276
  set gdb_transcript ""
3277
 
3278
  global gdb_trans_count
3279
  set gdb_trans_count 1
3280
 
3281
  proc remote_spawn {args} {
3282
    global gdb_transcript gdb_trans_count outdir
3283
 
3284
    if {$gdb_transcript != ""} {
3285
      close $gdb_transcript
3286
    }
3287
    set gdb_transcript [open [file join $outdir transcript.$gdb_trans_count] w]
3288
    puts $gdb_transcript [lindex $args 1]
3289
    incr gdb_trans_count
3290
 
3291
    return [uplevel real_remote_spawn $args]
3292
  }
3293
 
3294
  proc remote_close {args} {
3295
    global gdb_transcript
3296
 
3297
    if {$gdb_transcript != ""} {
3298
      close $gdb_transcript
3299
      set gdb_transcript ""
3300
    }
3301
 
3302
    return [uplevel real_remote_close $args]
3303
  }
3304
 
3305
  proc send_gdb {args} {
3306
    global gdb_transcript
3307
 
3308
    if {$gdb_transcript != ""} {
3309
      puts -nonewline $gdb_transcript [lindex $args 0]
3310
    }
3311
 
3312
    return [uplevel real_send_gdb $args]
3313
  }
3314
}
3315
 
3316
proc core_find {binfile {deletefiles {}} {arg ""}} {
3317
    global objdir subdir
3318
 
3319
    set destcore "$binfile.core"
3320
    file delete $destcore
3321
 
3322
    # Create a core file named "$destcore" rather than just "core", to
3323
    # avoid problems with sys admin types that like to regularly prune all
3324
    # files named "core" from the system.
3325
    #
3326
    # Arbitrarily try setting the core size limit to "unlimited" since
3327
    # this does not hurt on systems where the command does not work and
3328
    # allows us to generate a core on systems where it does.
3329
    #
3330
    # Some systems append "core" to the name of the program; others append
3331
    # the name of the program to "core"; still others (like Linux, as of
3332
    # May 2003) create cores named "core.PID".  In the latter case, we
3333
    # could have many core files lying around, and it may be difficult to
3334
    # tell which one is ours, so let's run the program in a subdirectory.
3335
    set found 0
3336
    set coredir "${objdir}/${subdir}/coredir.[getpid]"
3337
    file mkdir $coredir
3338
    catch "system \"(cd ${coredir}; ulimit -c unlimited; ${binfile} ${arg}; true) >/dev/null 2>&1\""
3339
    #      remote_exec host "${binfile}"
3340
    foreach i "${coredir}/core ${coredir}/core.coremaker.c ${binfile}.core" {
3341
        if [remote_file build exists $i] {
3342
            remote_exec build "mv $i $destcore"
3343
            set found 1
3344
        }
3345
    }
3346
    # Check for "core.PID".
3347
    if { $found == 0 } {
3348
        set names [glob -nocomplain -directory $coredir core.*]
3349
        if {[llength $names] == 1} {
3350
            set corefile [file join $coredir [lindex $names 0]]
3351
            remote_exec build "mv $corefile $destcore"
3352
            set found 1
3353
        }
3354
    }
3355
    if { $found == 0 } {
3356
        # The braindamaged HPUX shell quits after the ulimit -c above
3357
        # without executing ${binfile}.  So we try again without the
3358
        # ulimit here if we didn't find a core file above.
3359
        # Oh, I should mention that any "braindamaged" non-Unix system has
3360
        # the same problem. I like the cd bit too, it's really neat'n stuff.
3361
        catch "system \"(cd ${objdir}/${subdir}; ${binfile}; true) >/dev/null 2>&1\""
3362
        foreach i "${objdir}/${subdir}/core ${objdir}/${subdir}/core.coremaker.c ${binfile}.core" {
3363
            if [remote_file build exists $i] {
3364
                remote_exec build "mv $i $destcore"
3365
                set found 1
3366
            }
3367
        }
3368
    }
3369
 
3370
    # Try to clean up after ourselves.
3371
    foreach deletefile $deletefiles {
3372
        remote_file build delete [file join $coredir $deletefile]
3373
    }
3374
    remote_exec build "rmdir $coredir"
3375
 
3376
    if { $found == 0  } {
3377
        warning "can't generate a core file - core tests suppressed - check ulimit -c"
3378
        return ""
3379
    }
3380
    return $destcore
3381
}

powered by: WebSVN 2.1.0

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