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

Subversion Repositories openrisc

[/] [openrisc/] [trunk/] [gnu-old/] [gdb-6.8/] [gdb/] [testsuite/] [lib/] [mi-support.exp] - Blame information for rev 840

Details | Compare with Previous | View Log

Line No. Rev Author Line
1 24 jeremybenn
# Copyright 1999, 2000, 2002, 2003, 2004, 2005, 2007, 2008
2
# 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
# Please email any bugs, comments, and/or additions to this file to:
18
# bug-gdb@prep.ai.mit.edu
19
 
20
# This file was based on a file written by Fred Fish. (fnf@cygnus.com)
21
 
22
# Test setup routines that work with the MI interpreter.
23
 
24
# The variable mi_gdb_prompt is a regexp which matches the gdb mi prompt.
25
# Set it if it is not already set.
26
global mi_gdb_prompt
27
if ![info exists mi_gdb_prompt] then {
28
    set mi_gdb_prompt "\[(\]gdb\[)\] \r\n"
29
}
30
 
31
global mi_inferior_spawn_id
32
global mi_inferior_tty_name
33
 
34
set MIFLAGS "-i=mi"
35
 
36
#
37
# mi_gdb_exit -- exit the GDB, killing the target program if necessary
38
#
39
proc mi_gdb_exit {} {
40
    catch mi_uncatched_gdb_exit
41
}
42
 
43
proc mi_uncatched_gdb_exit {} {
44
    global GDB
45
    global GDBFLAGS
46
    global verbose
47
    global gdb_spawn_id;
48
    global gdb_prompt
49
    global mi_gdb_prompt
50
    global MIFLAGS
51
 
52
    gdb_stop_suppressing_tests;
53
 
54
    if { [info procs sid_exit] != "" } {
55
        sid_exit
56
    }
57
 
58
    if ![info exists gdb_spawn_id] {
59
        return;
60
    }
61
 
62
    verbose "Quitting $GDB $GDBFLAGS $MIFLAGS"
63
 
64
    if { [is_remote host] && [board_info host exists fileid] } {
65
        send_gdb "999-gdb-exit\n";
66
        gdb_expect 10 {
67
            -re "y or n" {
68
                send_gdb "y\n";
69
                exp_continue;
70
            }
71
            -re "Undefined command.*$gdb_prompt $" {
72
                send_gdb "quit\n"
73
                exp_continue;
74
            }
75
            -re "DOSEXIT code" { }
76
            default { }
77
        }
78
    }
79
 
80
    if ![is_remote host] {
81
        remote_close host;
82
    }
83
    unset gdb_spawn_id
84
}
85
 
86
#
87
# mi_gdb_start [INFERIOR_PTY] -- start gdb running, default procedure
88
#
89
# INFERIOR_PTY should be set to separate-inferior-tty to have the inferior work
90
# with it's own PTY. If set to same-inferior-tty, the inferior shares GDB's PTY.
91
# The default value is same-inferior-tty.
92
#
93
# When running over NFS, particularly if running many simultaneous
94
# tests on different hosts all using the same server, things can
95
# get really slow.  Give gdb at least 3 minutes to start up.
96
#
97
proc mi_gdb_start { args } {
98
    global verbose
99
    global GDB
100
    global GDBFLAGS
101
    global gdb_prompt
102
    global mi_gdb_prompt
103
    global timeout
104
    global gdb_spawn_id;
105
    global MIFLAGS
106
 
107
    gdb_stop_suppressing_tests;
108
    set inferior_pty no-tty
109
 
110
    if { [llength $args] == 1} {
111
        set inferior_pty [lindex $args 0]
112
    }
113
 
114
    set separate_inferior_pty [string match $inferior_pty separate-inferior-tty]
115
 
116
    # Start SID.
117
    if { [info procs sid_start] != "" } {
118
        verbose "Spawning SID"
119
        sid_start
120
    }
121
 
122
    verbose "Spawning $GDB -nw $GDBFLAGS $MIFLAGS"
123
 
124
    if [info exists gdb_spawn_id] {
125
        return 0;
126
    }
127
 
128
    if ![is_remote host] {
129
        if { [which $GDB] == 0 } then {
130
            perror "$GDB does not exist."
131
            exit 1
132
        }
133
    }
134
 
135
    # Create the new PTY for the inferior process.
136
    if { $separate_inferior_pty } {
137
        spawn -pty
138
        global mi_inferior_spawn_id
139
        global mi_inferior_tty_name
140
        set mi_inferior_spawn_id $spawn_id
141
        set mi_inferior_tty_name $spawn_out(slave,name)
142
    }
143
 
144
    set res [remote_spawn host "$GDB -nw $GDBFLAGS $MIFLAGS [host_info gdb_opts]"];
145
    if { $res < 0 || $res == "" } {
146
        perror "Spawning $GDB failed."
147
        return 1;
148
    }
149
    gdb_expect {
150
        -re "~\"GNU.*\r\n~\".*$mi_gdb_prompt$" {
151
            # We have a new format mi startup prompt.  If we are
152
            # running mi1, then this is an error as we should be
153
            # using the old-style prompt.
154
            if { $MIFLAGS == "-i=mi1" } {
155
                perror "(mi startup) Got unexpected new mi prompt."
156
                remote_close host;
157
                return -1;
158
            }
159
            verbose "GDB initialized."
160
        }
161
        -re "\[^~\].*$mi_gdb_prompt$" {
162
            # We have an old format mi startup prompt.  If we are
163
            # not running mi1, then this is an error as we should be
164
            # using the new-style prompt.
165
            if { $MIFLAGS != "-i=mi1" } {
166
                perror "(mi startup) Got unexpected old mi prompt."
167
                remote_close host;
168
                return -1;
169
            }
170
            verbose "GDB initialized."
171
        }
172
        -re ".*$gdb_prompt $" {
173
            untested "Skip mi tests (got non-mi prompt)."
174
            remote_close host;
175
            return -1;
176
        }
177
        -re ".*unrecognized option.*for a complete list of options." {
178
            untested "Skip mi tests (not compiled with mi support)."
179
            remote_close host;
180
            return -1;
181
        }
182
        -re ".*Interpreter `mi' unrecognized." {
183
            untested "Skip mi tests (not compiled with mi support)."
184
            remote_close host;
185
            return -1;
186
        }
187
        timeout {
188
            perror "(timeout) GDB never initialized after 10 seconds."
189
            remote_close host;
190
            return -1
191
        }
192
    }
193
    set gdb_spawn_id -1;
194
 
195
    # FIXME: mi output does not go through pagers, so these can be removed.
196
    # force the height to "unlimited", so no pagers get used
197
    send_gdb "100-gdb-set height 0\n"
198
    gdb_expect 10 {
199
        -re ".*100-gdb-set height 0\r\n100\\\^done\r\n$mi_gdb_prompt$" {
200
            verbose "Setting height to 0." 2
201
        }
202
        timeout {
203
            warning "Couldn't set the height to 0"
204
        }
205
    }
206
    # force the width to "unlimited", so no wraparound occurs
207
    send_gdb "101-gdb-set width 0\n"
208
    gdb_expect 10 {
209
        -re ".*101-gdb-set width 0\r\n101\\\^done\r\n$mi_gdb_prompt$" {
210
            verbose "Setting width to 0." 2
211
        }
212
        timeout {
213
            warning "Couldn't set the width to 0."
214
        }
215
    }
216
    # If allowing the inferior to have its own PTY then assign the inferior
217
    # its own terminal device here.
218
    if { $separate_inferior_pty } {
219
        send_gdb "102-inferior-tty-set $mi_inferior_tty_name\n"
220
        gdb_expect 10 {
221
            -re ".*102\\\^done\r\n$mi_gdb_prompt$" {
222
                verbose "redirect inferior output to new terminal device."
223
            }
224
            timeout {
225
                warning "Couldn't redirect inferior output." 2
226
            }
227
        }
228
    }
229
 
230
    return 0;
231
}
232
 
233
# Many of the tests depend on setting breakpoints at various places and
234
# running until that breakpoint is reached.  At times, we want to start
235
# with a clean-slate with respect to breakpoints, so this utility proc
236
# lets us do this without duplicating this code everywhere.
237
#
238
 
239
proc mi_delete_breakpoints {} {
240
    global mi_gdb_prompt
241
 
242
# FIXME: The mi operation won't accept a prompt back and will use the 'all' arg
243
    send_gdb "102-break-delete\n"
244
    gdb_expect 30 {
245
         -re "Delete all breakpoints.*y or n.*$" {
246
            send_gdb "y\n";
247
            exp_continue
248
         }
249
         -re "102-break-delete\r\n102\\\^done\r\n$mi_gdb_prompt$" {
250
            # This happens if there were no breakpoints
251
         }
252
         timeout { perror "Delete all breakpoints in mi_delete_breakpoints (timeout)" ; return }
253
    }
254
 
255
# The correct output is not "No breakpoints or watchpoints." but an
256
# empty BreakpointTable. Also, a query is not acceptable with mi.
257
    send_gdb "103-break-list\n"
258
    gdb_expect 30 {
259
         -re "103-break-list\r\n103\\\^done,BreakpointTable=\{\}\r\n$mi_gdb_prompt$" {}
260
         -re "103-break-list\r\n103\\\^done,BreakpointTable=\{nr_rows=\".\",nr_cols=\".\",hdr=\\\[\{width=\".*\",alignment=\".*\",col_name=\"number\",colhdr=\"Num\"\}.*colhdr=\"Type\".*colhdr=\"Disp\".*colhdr=\"Enb\".*colhdr=\"Address\".*colhdr=\"What\".*\\\],body=\\\[\\\]\}" {}
261
         -re "103-break-list\r\n103\\\^doneNo breakpoints or watchpoints.\r\n\r\n$mi_gdb_prompt$" {warning "Unexpected console text received"}
262
         -re "$mi_gdb_prompt$" { perror "Breakpoints not deleted" ; return }
263
         -re "Delete all breakpoints.*or n.*$" {
264
            warning "Unexpected prompt for breakpoints deletion";
265
            send_gdb "y\n";
266
            exp_continue
267
        }
268
         timeout { perror "-break-list (timeout)" ; return }
269
    }
270
}
271
 
272
proc mi_gdb_reinitialize_dir { subdir } {
273
    global mi_gdb_prompt
274
    global MIFLAGS
275
 
276
    global suppress_flag
277
    if { $suppress_flag } {
278
        return
279
    }
280
 
281
    if [is_remote host] {
282
        return "";
283
    }
284
 
285
    if { $MIFLAGS == "-i=mi1" } {
286
      send_gdb "104-environment-directory\n"
287
      gdb_expect 60 {
288
        -re ".*Reinitialize source path to empty.*y or n. " {
289
            warning "Got confirmation prompt for dir reinitialization."
290
            send_gdb "y\n"
291
            gdb_expect 60 {
292
                -re "$mi_gdb_prompt$" {}
293
                timeout {error "Dir reinitialization failed (timeout)"}
294
            }
295
        }
296
        -re "$mi_gdb_prompt$" {}
297
        timeout {error "Dir reinitialization failed (timeout)"}
298
      }
299
    } else {
300
      send_gdb "104-environment-directory -r\n"
301
      gdb_expect 60 {
302
        -re "104\\\^done,source-path=.*\r\n$mi_gdb_prompt$" {}
303
        -re "$mi_gdb_prompt$" {}
304
        timeout {error "Dir reinitialization failed (timeout)"}
305
      }
306
    }
307
 
308
    send_gdb "105-environment-directory $subdir\n"
309
    gdb_expect 60 {
310
        -re "Source directories searched.*$mi_gdb_prompt$" {
311
            verbose "Dir set to $subdir"
312
        }
313
        -re "105\\\^done.*\r\n$mi_gdb_prompt$" {
314
            # FIXME: We return just the prompt for now.
315
            verbose "Dir set to $subdir"
316
            # perror "Dir \"$subdir\" failed."
317
        }
318
    }
319
}
320
 
321
# Send GDB the "target" command.
322
# FIXME: Some of these patterns are not appropriate for MI.  Based on
323
# config/monitor.exp:gdb_target_command.
324
proc mi_gdb_target_cmd { targetname serialport } {
325
    global mi_gdb_prompt
326
 
327
    set serialport_re [string_to_regexp $serialport]
328
    for {set i 1} {$i <= 3} {incr i} {
329
        send_gdb "47-target-select $targetname $serialport\n"
330
        gdb_expect 60 {
331
            -re "47\\^connected.*$mi_gdb_prompt$" {
332
                verbose "Set target to $targetname";
333
                return 0;
334
            }
335
            -re "unknown host.*$mi_gdb_prompt" {
336
                verbose "Couldn't look up $serialport"
337
            }
338
            -re "Couldn't establish connection to remote.*$mi_gdb_prompt$" {
339
                verbose "Connection failed";
340
            }
341
            -re "Remote MIPS debugging.*$mi_gdb_prompt$" {
342
                verbose "Set target to $targetname";
343
                return 0;
344
            }
345
            -re "Remote debugging using .*$serialport_re.*$mi_gdb_prompt$" {
346
                verbose "Set target to $targetname";
347
                return 0;
348
            }
349
            -re "Remote target $targetname connected to.*$mi_gdb_prompt$" {
350
                verbose "Set target to $targetname";
351
                return 0;
352
            }
353
            -re "Connected to.*$mi_gdb_prompt$" {
354
                verbose "Set target to $targetname";
355
                return 0;
356
            }
357
            -re "Ending remote.*$mi_gdb_prompt$" { }
358
            -re "Connection refused.*$mi_gdb_prompt$" {
359
                verbose "Connection refused by remote target.  Pausing, and trying again."
360
                sleep 5
361
                continue
362
            }
363
            -re "Timeout reading from remote system.*$mi_gdb_prompt$" {
364
                verbose "Got timeout error from gdb.";
365
            }
366
            timeout {
367
                send_gdb "";
368
                break
369
            }
370
        }
371
    }
372
    return 1
373
}
374
 
375
#
376
# load a file into the debugger (file command only).
377
# return a -1 if anything goes wrong.
378
#
379
proc mi_gdb_file_cmd { arg } {
380
    global verbose
381
    global loadpath
382
    global loadfile
383
    global GDB
384
    global mi_gdb_prompt
385
    global last_loaded_file
386
    upvar timeout timeout
387
 
388
    set last_loaded_file $arg
389
 
390
    if [is_remote host] {
391
        set arg [remote_download host $arg];
392
        if { $arg == "" } {
393
            error "download failed"
394
            return -1;
395
        }
396
    }
397
 
398
# FIXME: Several of these patterns are only acceptable for console
399
# output.  Queries are an error for mi.
400
    send_gdb "105-file-exec-and-symbols $arg\n"
401
    gdb_expect 120 {
402
        -re "Reading symbols from.*done.*$mi_gdb_prompt$" {
403
            verbose "\t\tLoaded $arg into the $GDB"
404
            return 0
405
        }
406
        -re "has no symbol-table.*$mi_gdb_prompt$" {
407
            perror "$arg wasn't compiled with \"-g\""
408
            return -1
409
        }
410
        -re "Load new symbol table from \".*\".*y or n. $" {
411
            send_gdb "y\n"
412
            gdb_expect 120 {
413
                -re "Reading symbols from.*done.*$mi_gdb_prompt$" {
414
                    verbose "\t\tLoaded $arg with new symbol table into $GDB"
415
                    # All OK
416
                }
417
                timeout {
418
                    perror "(timeout) Couldn't load $arg, other program already loaded."
419
                    return -1
420
                }
421
            }
422
        }
423
        -re "No such file or directory.*$mi_gdb_prompt$" {
424
            perror "($arg) No such file or directory\n"
425
            return -1
426
        }
427
        -re "105-file-exec-and-symbols .*\r\n105\\\^done\r\n$mi_gdb_prompt$" {
428
            # We (MI) are just giving the prompt back for now, instead of giving
429
            # some acknowledgement.
430
            return 0
431
        }
432
        timeout {
433
            perror "couldn't load $arg into $GDB (timed out)."
434
            return -1
435
        }
436
        eof {
437
            # This is an attempt to detect a core dump, but seems not to
438
            # work.  Perhaps we need to match .* followed by eof, in which
439
            # gdb_expect does not seem to have a way to do that.
440
            perror "couldn't load $arg into $GDB (end of file)."
441
            return -1
442
        }
443
    }
444
}
445
 
446
#
447
# connect to the target and download a file, if necessary.
448
# return a -1 if anything goes wrong.
449
#
450
proc mi_gdb_target_load { } {
451
    global verbose
452
    global loadpath
453
    global loadfile
454
    global GDB
455
    global mi_gdb_prompt
456
    upvar timeout timeout
457
 
458
    if { [info procs gdbserver_gdb_load] != "" } {
459
        mi_gdb_test "kill" ".*" ""
460
        set res [gdbserver_gdb_load]
461
        set protocol [lindex $res 0]
462
        set gdbport [lindex $res 1]
463
 
464
        if { [mi_gdb_target_cmd $protocol $gdbport] != 0 } {
465
            return -1
466
        }
467
    } elseif { [info procs send_target_sid] != "" } {
468
        # For SID, things get complex
469
        send_gdb "kill\n"
470
        gdb_expect 10 {
471
            -re ".*$mi_gdb_prompt$"
472
        }
473
        send_target_sid
474
        gdb_expect 60 {
475
            -re "\\^done.*$mi_gdb_prompt$" {
476
            }
477
            timeout {
478
                perror "Unable to connect to SID target"
479
                return -1
480
            }
481
        }
482
        send_gdb "48-target-download\n"
483
        gdb_expect 10 {
484
            -re "48\\^done.*$mi_gdb_prompt$" {
485
            }
486
            timeout {
487
                perror "Unable to download to SID target"
488
                return -1
489
            }
490
        }
491
    } elseif { [target_info protocol] == "sim" } {
492
        # For the simulator, just connect to it directly.
493
        send_gdb "47-target-select sim\n"
494
        gdb_expect 10 {
495
            -re "47\\^connected.*$mi_gdb_prompt$" {
496
            }
497
            timeout {
498
                perror "Unable to select sim target"
499
                return -1
500
            }
501
        }
502
        send_gdb "48-target-download\n"
503
        gdb_expect 10 {
504
            -re "48\\^done.*$mi_gdb_prompt$" {
505
            }
506
            timeout {
507
                perror "Unable to download to sim target"
508
                return -1
509
            }
510
        }
511
    } elseif { [target_info gdb_protocol] == "remote" } {
512
        # remote targets
513
        if { [mi_gdb_target_cmd "remote" [target_info netport]] != 0 } {
514
            perror "Unable to connect to remote target"
515
            return -1
516
        }
517
        send_gdb "48-target-download\n"
518
        gdb_expect 10 {
519
            -re "48\\^done.*$mi_gdb_prompt$" {
520
            }
521
            timeout {
522
                perror "Unable to download to remote target"
523
                return -1
524
            }
525
        }
526
    }
527
    return 0
528
}
529
 
530
#
531
# load a file into the debugger.
532
# return a -1 if anything goes wrong.
533
#
534
proc mi_gdb_load { arg } {
535
    if { $arg != "" } {
536
        return [mi_gdb_file_cmd $arg]
537
    }
538
    return 0
539
}
540
 
541
# mi_gdb_test COMMAND PATTERN MESSAGE [IPATTERN] -- send a command to gdb;
542
#   test the result.
543
#
544
# COMMAND is the command to execute, send to GDB with send_gdb.  If
545
#   this is the null string no command is sent.
546
# PATTERN is the pattern to match for a PASS, and must NOT include
547
#   the \r\n sequence immediately before the gdb prompt.
548
# MESSAGE is the message to be printed.  (If this is the empty string,
549
#   then sometimes we don't call pass or fail at all; I don't
550
#   understand this at all.)
551
# IPATTERN is the pattern to match for the inferior's output.  This parameter
552
#   is optional.  If present, it will produce a PASS if the match is
553
#   successful, and a FAIL if unsuccessful.
554
#
555
# Returns:
556
#    1 if the test failed,
557
#    0 if the test passes,
558
#   -1 if there was an internal error.
559
#
560
proc mi_gdb_test { args } {
561
    global verbose
562
    global mi_gdb_prompt
563
    global GDB expect_out
564
    upvar timeout timeout
565
 
566
    set command [lindex $args 0]
567
    set pattern [lindex $args 1]
568
    set message [lindex $args 2]
569
 
570
    if [llength $args]==4 {
571
        set ipattern [lindex $args 3]
572
    }
573
 
574
    if [llength $args]==5 {
575
        set question_string [lindex $args 3];
576
        set response_string [lindex $args 4];
577
    } else {
578
        set question_string "^FOOBAR$"
579
    }
580
 
581
    if $verbose>2 then {
582
        send_user "Sending \"$command\" to gdb\n"
583
        send_user "Looking to match \"$pattern\"\n"
584
        send_user "Message is \"$message\"\n"
585
    }
586
 
587
    set result -1
588
    set string "${command}\n";
589
    set string_regex [string_to_regexp $command]
590
 
591
    if { $command != "" } {
592
        while { "$string" != "" } {
593
            set foo [string first "\n" "$string"];
594
            set len [string length "$string"];
595
            if { $foo < [expr $len - 1] } {
596
                set str [string range "$string" 0 $foo];
597
                if { [send_gdb "$str"] != "" } {
598
                    global suppress_flag;
599
 
600
                    if { ! $suppress_flag } {
601
                        perror "Couldn't send $command to GDB.";
602
                    }
603
                    fail "$message";
604
                    return $result;
605
                }
606
                gdb_expect 2 {
607
                    -re "\[\r\n\]" { }
608
                    timeout { }
609
                }
610
                set string [string range "$string" [expr $foo + 1] end];
611
            } else {
612
                break;
613
            }
614
        }
615
        if { "$string" != "" } {
616
            if { [send_gdb "$string"] != "" } {
617
                global suppress_flag;
618
 
619
                if { ! $suppress_flag } {
620
                    perror "Couldn't send $command to GDB.";
621
                }
622
                fail "$message";
623
                return $result;
624
            }
625
        }
626
    }
627
 
628
    if [info exists timeout] {
629
        set tmt $timeout;
630
    } else {
631
        global timeout;
632
        if [info exists timeout] {
633
            set tmt $timeout;
634
        } else {
635
            set tmt 60;
636
        }
637
    }
638
    gdb_expect $tmt {
639
         -re "\\*\\*\\* DOSEXIT code.*" {
640
             if { $message != "" } {
641
                 fail "$message";
642
             }
643
             gdb_suppress_entire_file "GDB died";
644
             return -1;
645
         }
646
         -re "Ending remote debugging.*$mi_gdb_prompt\[ \]*$" {
647
            if ![isnative] then {
648
                warning "Can`t communicate to remote target."
649
            }
650
            gdb_exit
651
            gdb_start
652
            set result -1
653
        }
654
         -re "^($string_regex\[\r\n\]+)?($pattern\[\r\n\]+$mi_gdb_prompt\[ \]*)" {
655
            # At this point, $expect_out(1,string) is the MI input command.
656
            # and $expect_out(2,string) is the MI output command.
657
            # If $expect_out(1,string) is "", then there was no MI input command here.
658
 
659
            # NOTE, there is no trailing anchor because with GDB/MI,
660
            # asynchronous responses can happen at any point, causing more
661
            # data to be available.  Normally an anchor is used to make
662
            # sure the end of the output is matched, however, $mi_gdb_prompt
663
            # is just as good of an anchor since mi_gdb_test is meant to
664
            # match a single mi output command.  If a second GDB/MI output
665
            # response is sent, it will be in the buffer for the next
666
            # time mi_gdb_test is called.
667
            if ![string match "" $message] then {
668
                pass "$message"
669
            }
670
            set result 0
671
        }
672
         -re "(${question_string})$" {
673
            send_gdb "$response_string\n";
674
            exp_continue;
675
        }
676
         -re "Undefined.* command:.*$mi_gdb_prompt\[ \]*$" {
677
            perror "Undefined command \"$command\"."
678
            fail "$message"
679
            set result 1
680
        }
681
         -re "Ambiguous command.*$mi_gdb_prompt\[ \]*$" {
682
            perror "\"$command\" is not a unique command name."
683
            fail "$message"
684
            set result 1
685
        }
686
         -re "Program exited with code \[0-9\]+.*$mi_gdb_prompt\[ \]*$" {
687
            if ![string match "" $message] then {
688
                set errmsg "$message (the program exited)"
689
            } else {
690
                set errmsg "$command (the program exited)"
691
            }
692
            fail "$errmsg"
693
            return -1
694
        }
695
         -re "The program is not being run.*$mi_gdb_prompt\[ \]*$" {
696
            if ![string match "" $message] then {
697
                set errmsg "$message (the program is no longer running)"
698
            } else {
699
                set errmsg "$command (the program is no longer running)"
700
            }
701
            fail "$errmsg"
702
            return -1
703
        }
704
         -re ".*$mi_gdb_prompt\[ \]*$" {
705
            if ![string match "" $message] then {
706
                fail "$message"
707
            }
708
            set result 1
709
        }
710
         "" {
711
            send_gdb "\n"
712
            perror "Window too small."
713
            fail "$message"
714
        }
715
         -re "\\(y or n\\) " {
716
            send_gdb "n\n"
717
            perror "Got interactive prompt."
718
            fail "$message"
719
        }
720
         eof {
721
             perror "Process no longer exists"
722
             if { $message != "" } {
723
                 fail "$message"
724
             }
725
             return -1
726
        }
727
         full_buffer {
728
            perror "internal buffer is full."
729
            fail "$message"
730
        }
731
        timeout {
732
            if ![string match "" $message] then {
733
                fail "$message (timeout)"
734
            }
735
            set result 1
736
        }
737
    }
738
 
739
    # If the GDB output matched, compare the inferior output.
740
    if { $result == 0 } {
741
        if [ info exists ipattern ] {
742
            if { ![target_info exists gdb,noinferiorio] } {
743
                global mi_inferior_spawn_id
744
                expect {
745
                    -i $mi_inferior_spawn_id -re "$ipattern" {
746
                        pass "$message inferior output"
747
                    }
748
                    timeout {
749
                        fail "$message inferior output (timeout)"
750
                        set result 1
751
                    }
752
                }
753
            } else {
754
                unsupported "$message inferior output"
755
            }
756
        }
757
    }
758
 
759
    return $result
760
}
761
 
762
#
763
# MI run command.  (A modified version of gdb_run_cmd)
764
#
765
 
766
# In patterns, the newline sequence ``\r\n'' is matched explicitly as
767
# ``.*$'' could swallow up output that we attempt to match elsewhere.
768
 
769
proc mi_run_cmd {args} {
770
    global suppress_flag
771
    if { $suppress_flag } {
772
        return -1
773
    }
774
    global mi_gdb_prompt
775
 
776
    if [target_info exists gdb_init_command] {
777
        send_gdb "[target_info gdb_init_command]\n";
778
        gdb_expect 30 {
779
            -re "$mi_gdb_prompt$" { }
780
            default {
781
                perror "gdb_init_command for target failed";
782
                return;
783
            }
784
        }
785
    }
786
 
787
    if { [mi_gdb_target_load] < 0 } {
788
        return
789
    }
790
 
791
    if [target_info exists use_gdb_stub] {
792
        if [target_info exists gdb,do_reload_on_run] {
793
            send_gdb "000-exec-continue\n";
794
            gdb_expect 60 {
795
                -re "000\\^running\[\r\n\]+$mi_gdb_prompt$" {}
796
                default {}
797
            }
798
            return;
799
        }
800
 
801
        if [target_info exists gdb,start_symbol] {
802
            set start [target_info gdb,start_symbol];
803
        } else {
804
            set start "start";
805
        }
806
 
807
        # HACK: Should either use 000-jump or fix the target code
808
        # to better handle RUN.
809
        send_gdb  "jump *$start\n"
810
        warning "Using CLI jump command, expect run-to-main FAIL"
811
        return
812
    }
813
 
814
    send_gdb "000-exec-run $args\n"
815
    gdb_expect {
816
        -re "000\\^running\r\n${mi_gdb_prompt}" {
817
        }
818
        timeout {
819
            perror "Unable to start target"
820
            return
821
        }
822
    }
823
    # NOTE: Shortly after this there will be a ``000*stopped,...(gdb)''
824
}
825
 
826
#
827
# Just like run-to-main but works with the MI interface
828
#
829
 
830
proc mi_run_to_main { } {
831
    global suppress_flag
832
    if { $suppress_flag } {
833
        return -1
834
    }
835
 
836
    global srcdir
837
    global subdir
838
    global binfile
839
    global srcfile
840
 
841
    mi_delete_breakpoints
842
    mi_gdb_reinitialize_dir $srcdir/$subdir
843
    mi_gdb_load ${binfile}
844
 
845
    mi_runto main
846
}
847
 
848
 
849
# Just like gdb's "runto" proc, it will run the target to a given
850
# function.  The big difference here between mi_runto and mi_execute_to
851
# is that mi_execute_to must have the inferior running already.  This
852
# proc will (like gdb's runto) (re)start the inferior, too.
853
#
854
# FUNC is the linespec of the place to stop (it inserts a breakpoint here).
855
# It returns:
856
#   -1  if test suppressed, failed, timedout
857
#    0  if test passed
858
 
859
proc mi_runto_helper {func run_or_continue} {
860
  global suppress_flag
861
  if { $suppress_flag } {
862
    return -1
863
  }
864
 
865
  global mi_gdb_prompt expect_out
866
  global hex decimal fullname_syntax
867
 
868
  set test "mi runto $func"
869
  mi_gdb_test "200-break-insert -t $func" \
870
    "200\\^done,bkpt=\{number=\"\[0-9\]+\",type=\"breakpoint\",disp=\"del\",enabled=\"y\",addr=\"$hex\",func=\"$func\(\\\(.*\\\)\)?\",file=\".*\",line=\"\[0-9\]*\",times=\"0\"\}" \
871
    "breakpoint at $func"
872
 
873
  if {![regexp {number="[0-9]+"} $expect_out(buffer) str]
874
      || ![scan $str {number="%d"} bkptno]} {
875
    set bkptno {[0-9]+}
876
  }
877
 
878
  if {$run_or_continue == "run"} {
879
      mi_run_cmd
880
  } else {
881
      send_gdb "000-exec-continue\n"
882
      gdb_expect {
883
          -re "000\\^running\r\n${mi_gdb_prompt}" {
884
          }
885
          timeout {
886
            fail "$test"
887
            return -1
888
          }
889
      }
890
  }
891
 
892
  gdb_expect {
893
    -re ".*000\\*stopped,thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\"$func\",args=\(\\\[.*\\\]\|\{.*\}\),file=\".*\",fullname=\"${fullname_syntax}.*\",line=\"\[0-9\]*\"\}\r\n$mi_gdb_prompt$" {
894
      pass "$test"
895
      return 0
896
    }
897
    -re ".*$mi_gdb_prompt$" {
898
      fail "$test (2)"
899
    }
900
    timeout {
901
      fail "$test (timeout)"
902
      return -1
903
    }
904
  }
905
}
906
 
907
proc mi_runto {func} {
908
    mi_runto_helper $func "run"
909
}
910
 
911
# Next to the next statement
912
# For return values, see mi_execute_to_helper
913
 
914
proc mi_next { test } {
915
  return [mi_next_to {.*} {.*} {.*} {.*} $test]
916
}
917
 
918
 
919
# Step to the next statement
920
# For return values, see mi_execute_to_helper
921
 
922
proc mi_step { test } {
923
  return [mi_step_to {.*} {.*} {.*} {.*} $test]
924
}
925
 
926
# cmd should not include the number or newline (i.e. "exec-step 3", not
927
# "220-exec-step 3\n"
928
 
929
# Can not match -re ".*\r\n${mi_gdb_prompt}", because of false positives
930
# after the first prompt is printed.
931
 
932
proc mi_execute_to_helper { cmd reason func args file line extra test } {
933
    global suppress_flag
934
    if { $suppress_flag } {
935
        return -1
936
    }
937
    global mi_gdb_prompt
938
    global hex
939
    global decimal
940
    global fullname_syntax
941
    send_gdb "220-$cmd\n"
942
    gdb_expect {
943
        -re "220\\^running\r\n${mi_gdb_prompt}.*220\\*stopped,reason=\"$reason\",thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\"$func\",args=$args,file=\".*$file\",fullname=\"${fullname_syntax}$file\",line=\"$line\"\}$extra\r\n$mi_gdb_prompt$" {
944
            pass "$test"
945
            return 0
946
        }
947
        -re "220\\^running\r\n${mi_gdb_prompt}.*220\\*stopped,reason=\"$reason\",thread-id=\"$decimal\",frame=\{addr=\"$hex\",func=\".*\",args=\[\\\[\{\].*\[\\\]\}\],file=\".*\",fullname=\"${fullname_syntax}.*\",line=\"\[0-9\]*\"\}.*\r\n$mi_gdb_prompt$" {
948
            fail "$test (stopped at wrong place)"
949
            return -1
950
        }
951
        -re "220\\^running\r\n${mi_gdb_prompt}.*\r\n${mi_gdb_prompt}$" {
952
            fail "$test (unknown output after running)"
953
            return -1
954
        }
955
        timeout {
956
            fail "$test (timeout)"
957
            return -1
958
        }
959
    }
960
}
961
 
962
proc mi_execute_to { cmd reason func args file line extra test } {
963
    mi_execute_to_helper "$cmd" "$reason" "$func" "\\\[$args\\\]" \
964
        "$file" "$line" "$extra" "$test"
965
}
966
 
967
proc mi_next_to { func args file line test } {
968
    mi_execute_to "exec-next" "end-stepping-range" "$func" "$args" \
969
        "$file" "$line" "" "$test"
970
}
971
 
972
proc mi_step_to { func args file line test } {
973
    mi_execute_to "exec-step" "end-stepping-range" "$func" "$args" \
974
        "$file" "$line" "" "$test"
975
}
976
 
977
proc mi_finish_to { func args file line result ret test } {
978
    mi_execute_to "exec-finish" "function-finished" "$func" "$args" \
979
        "$file" "$line" \
980
        ",gdb-result-var=\"$result\",return-value=\"$ret\"" \
981
        "$test"
982
}
983
 
984
proc mi_continue_to {func} {
985
    mi_runto_helper $func "continue"
986
}
987
 
988
proc mi0_execute_to { cmd reason func args file line extra test } {
989
    mi_execute_to_helper "$cmd" "$reason" "$func" "\{$args\}" \
990
        "$file" "$line" "$extra" "$test"
991
}
992
 
993
proc mi0_next_to { func args file line test } {
994
    mi0_execute_to "exec-next" "end-stepping-range" "$func" "$args" \
995
        "$file" "$line" "" "$test"
996
}
997
 
998
proc mi0_step_to { func args file line test } {
999
    mi0_execute_to "exec-step" "end-stepping-range" "$func" "$args" \
1000
        "$file" "$line" "" "$test"
1001
}
1002
 
1003
proc mi0_finish_to { func args file line result ret test } {
1004
    mi0_execute_to "exec-finish" "function-finished" "$func" "$args" \
1005
        "$file" "$line" \
1006
        ",gdb-result-var=\"$result\",return-value=\"$ret\"" \
1007
        "$test"
1008
}
1009
 
1010
proc mi0_continue_to { bkptno func args file line test } {
1011
    mi0_execute_to "exec-continue" "breakpoint-hit\",bkptno=\"$bkptno" \
1012
        "$func" "$args" "$file" "$line" "" "$test"
1013
}
1014
 
1015
# Creates varobj named NAME for EXPRESSION.
1016
# Name cannot be "-".
1017
proc mi_create_varobj { name expression testname } {
1018
    mi_gdb_test "-var-create $name * $expression" \
1019
        "\\^done,name=\"$name\",numchild=\"\[0-9\]+\",value=\".*\",type=.*" \
1020
        $testname
1021
}
1022
 
1023
# Deletes the specified NAME.
1024
proc mi_delete_varobj { name testname } {
1025
    mi_gdb_test "-var-delete $name" \
1026
        "\\^done,ndeleted=.*" \
1027
        $testname
1028
}
1029
 
1030
# Updates varobj named NAME and checks that all varobjs in EXPECTED
1031
# are reported as updated, and no other varobj is updated.
1032
# Assumes that no varobj is out of scope and that no varobj changes
1033
# types.
1034
proc mi_varobj_update { name expected testname } {
1035
    set er "\\^done,changelist=\\\["
1036
    set first 1
1037
    foreach item $expected {
1038
        set v "{name=\"$item\",in_scope=\"true\",type_changed=\"false\"}"
1039
        if {$first == 1} {
1040
            set er "$er$v"
1041
            set first 0
1042
        } else {
1043
            set er "$er,$v"
1044
        }
1045
    }
1046
    set er "$er\\\]"
1047
 
1048
    verbose -log "Expecting: $er" 2
1049
    mi_gdb_test "-var-update $name" $er $testname
1050
}
1051
 
1052
proc mi_check_varobj_value { name value testname } {
1053
 
1054
    mi_gdb_test "-var-evaluate-expression $name" \
1055
        "\\^done,value=\"$value\"" \
1056
        $testname
1057
}
1058
 
1059
# Check the results of the:
1060
#
1061
#   -var-list-children VARNAME
1062
#
1063
# command.  The CHILDREN parement should be a list of lists.
1064
# Each inner list can have either 3 or 4 elements, describing
1065
# fields that gdb is expected to report for child variable object,
1066
# in the following order
1067
#
1068
#   - Name
1069
#   - Expression
1070
#   - Number of children
1071
#   - Type
1072
#
1073
# If inner list has 3 elements, the gdb is expected to output no
1074
# type for a child.
1075
#
1076
proc mi_list_varobj_children { varname children testname } {
1077
 
1078
    set numchildren [llength $children]
1079
    set children_exp {}
1080
    set whatever "\"\[^\"\]+\""
1081
 
1082
    foreach item $children {
1083
 
1084
        set name [lindex $item 0]
1085
        set exp [lindex $item  1]
1086
        set numchild [lindex $item 2]
1087
        if {[llength $item] == 4} {
1088
            set type [lindex $item 3]
1089
 
1090
            lappend children_exp\
1091
                "child={name=\"$name\",exp=\"$exp\",numchild=\"$numchild\",type=\"$type\"}"
1092
        } else {
1093
            lappend children_exp\
1094
                "child={name=\"$name\",exp=\"$exp\",numchild=\"$numchild\"}"
1095
        }
1096
    }
1097
    set children_exp_j [join $children_exp ","]
1098
    set expected "\\^done,numchild=\"$numchildren\",children=\\\[$children_exp_j\\\]"
1099
 
1100
    verbose -log "Expecting: $expected"
1101
 
1102
    mi_gdb_test "-var-list-children $varname" $expected $testname
1103
}
1104
 
1105
# A list of two-element lists.  First element of each list is
1106
# a Tcl statement, and the second element is the line
1107
# number of source C file where the statement originates.
1108
set mi_autotest_data ""
1109
# The name of the source file for autotesting.
1110
set mi_autotest_source ""
1111
 
1112
proc count_newlines { string } {
1113
    return [regexp -all "\n" $string]
1114
}
1115
 
1116
# Prepares for running inline tests in FILENAME.
1117
# See comments for mi_run_inline_test for detailed
1118
# explanation of the idea and syntax.
1119
proc mi_prepare_inline_tests { filename } {
1120
 
1121
    global srcdir
1122
    global subdir
1123
    global mi_autotest_source
1124
    global mi_autotest_data
1125
 
1126
    set mi_autotest_data {}
1127
 
1128
    set mi_autotest_source $filename
1129
 
1130
    if { ! [regexp "^/" "$filename"] } then {
1131
        set filename "$srcdir/$subdir/$filename"
1132
    }
1133
 
1134
    set chan [open $filename]
1135
    set content [read $chan]
1136
    set line_number 1
1137
    while {1} {
1138
        set start [string first "/*:" $content]
1139
        if {$start != -1} {
1140
            set end [string first ":*/" $content]
1141
            if {$end == -1} {
1142
                error "Unterminated special comment in $filename"
1143
            }
1144
 
1145
            set prefix [string range $content 0 $start]
1146
            set prefix_newlines [count_newlines $prefix]
1147
 
1148
            set line_number [expr $line_number+$prefix_newlines]
1149
            set comment_line $line_number
1150
 
1151
            set comment [string range $content [expr $start+3] [expr $end-1]]
1152
 
1153
            set comment_newlines [count_newlines $comment]
1154
            set line_number [expr $line_number+$comment_newlines]
1155
 
1156
            set comment [string trim $comment]
1157
            set content [string range $content [expr $end+3] \
1158
                             [string length $content]]
1159
            lappend mi_autotest_data [list $comment $comment_line]
1160
        } else {
1161
           break
1162
        }
1163
    }
1164
    close $chan
1165
}
1166
 
1167
# Helper to mi_run_inline_test below.
1168
# Return the list of all (statement,line_number) lists
1169
# that comprise TESTCASE.  The begin and end markers
1170
# are not included.
1171
proc mi_get_inline_test {testcase} {
1172
 
1173
    global mi_gdb_prompt
1174
    global mi_autotest_data
1175
    global mi_autotest_source
1176
 
1177
    set result {}
1178
 
1179
    set seen_begin 0
1180
    set seen_end 0
1181
    foreach l $mi_autotest_data {
1182
 
1183
        set comment [lindex $l 0]
1184
 
1185
        if {$comment == "BEGIN: $testcase"} {
1186
            set seen_begin 1
1187
        } elseif {$comment == "END: $testcase"} {
1188
            set seen_end 1
1189
            break
1190
        } elseif {$seen_begin==1} {
1191
            lappend result $l
1192
        }
1193
    }
1194
 
1195
    if {$seen_begin == 0} {
1196
        error "Autotest $testcase not found"
1197
    }
1198
 
1199
    if {$seen_begin == 1 && $seen_end == 0} {
1200
        error "Missing end marker for test $testcase"
1201
    }
1202
 
1203
    return $result
1204
}
1205
 
1206
# Sets temporary breakpoint at LOCATION.
1207
proc mi_tbreak {location} {
1208
 
1209
    global mi_gdb_prompt
1210
 
1211
    mi_gdb_test "-break-insert -t $location" \
1212
        {\^done,bkpt=.*} \
1213
        "run to $location (set breakpoint)"
1214
}
1215
 
1216
# Send COMMAND that must be a command that resumes
1217
# the inferiour (run/continue/next/etc) and consumes
1218
# the "^running" output from it.
1219
proc mi_send_resuming_command {command test} {
1220
 
1221
    global mi_gdb_prompt
1222
 
1223
    send_gdb "220-$command\n"
1224
    gdb_expect {
1225
        -re "220\\^running\r\n${mi_gdb_prompt}" {
1226
        }
1227
        timeout {
1228
            fail $test
1229
        }
1230
    }
1231
}
1232
 
1233
# Helper to mi_run_inline_test below.
1234
# Sets a temporary breakpoint at LOCATION and runs
1235
# the program using COMMAND.  When the program is stopped
1236
# returns the line at which it.  Returns -1 if line cannot
1237
# be determined.
1238
# Does not check that the line is the same as requested.
1239
# The caller can check itself if required.
1240
proc mi_continue_to_line {location test} {
1241
 
1242
    mi_tbreak $location
1243
    mi_send_resuming_command "exec-continue" "run to $location (exec-continue)"
1244
    return [mi_wait_for_stop $test]
1245
}
1246
 
1247
# Wait until gdb prints the current line.
1248
proc mi_wait_for_stop {test} {
1249
 
1250
  global mi_gdb_prompt
1251
 
1252
  gdb_expect {
1253
      -re ".*line=\"(.*)\".*\r\n$mi_gdb_prompt$" {
1254
          return $expect_out(1,string)
1255
      }
1256
      -re ".*$mi_gdb_prompt$" {
1257
          fail "wait for stop ($test)"
1258
      }
1259
      timeout {
1260
          fail "wait for stop ($test)"
1261
      }
1262
  }
1263
}
1264
 
1265
# Run a MI test embedded in comments in a C file.
1266
# The C file should contain special comments in the following
1267
# three forms:
1268
#
1269
#    /*: BEGIN: testname :*/
1270
#    /*:   :*/
1271
#    /*: END: testname :*/
1272
#
1273
# This procedure find the begin and end marker for the requested
1274
# test. Then, a temporary breakpoint is set at the begin
1275
# marker and the program is run (from start).
1276
#
1277
# After that, for each special comment between the begin and end
1278
# marker, the Tcl statements are executed.  It is assumed that
1279
# for each comment, the immediately preceding line is executable
1280
# C statement.  Then, gdb will be single-stepped until that
1281
# preceding C statement is executed, and after that the
1282
# Tcl statements in the comment will be executed.
1283
#
1284
# For example:
1285
#
1286
#     /*: BEGIN: assignment-test :*/
1287
#     v = 10;
1288
#     /*: 
1289
#     /*: END: assignment-test :*/
1290
#
1291
# The mi_prepare_inline_tests function should be called before
1292
# calling this function.  A given C file can contain several
1293
# inline tests.  The names of the tests must be unique within one
1294
# C file.
1295
#
1296
proc mi_run_inline_test { testcase } {
1297
 
1298
    global mi_gdb_prompt
1299
    global hex
1300
    global decimal
1301
    global fullname_syntax
1302
    global mi_autotest_source
1303
 
1304
    set commands [mi_get_inline_test $testcase]
1305
 
1306
    set first 1
1307
    set line_now 1
1308
 
1309
    foreach c $commands {
1310
        set statements [lindex $c 0]
1311
        set line [lindex $c 1]
1312
        set line [expr $line-1]
1313
 
1314
        # We want gdb to be stopped at the expression immediately
1315
        # before the comment.  If this is the first comment, the
1316
        # program is either not started yet or is in some random place,
1317
        # so we run it.  For further comments, we might be already
1318
        # standing at the right line. If not continue till the
1319
        # right line.
1320
 
1321
        if {$first==1} {
1322
            # Start the program afresh.
1323
            mi_tbreak "$mi_autotest_source:$line"
1324
            mi_run_cmd
1325
            set line_now [mi_wait_for_stop "$testcase: step to $line"]
1326
            set first 0
1327
        } elseif {$line_now!=$line} {
1328
            set line_now [mi_continue_to_line "$mi_autotest_source:$line" "continue to $line"]
1329
        }
1330
 
1331
        if {$line_now!=$line} {
1332
            fail "$testcase: go to line $line"
1333
        }
1334
 
1335
        # We're not at the statement right above the comment.
1336
        # Execute that statement so that the comment can test
1337
        # the state after the statement is executed.
1338
 
1339
        # Single-step past the line.
1340
        mi_send_resuming_command "exec-next" "$testcase: step over $line"
1341
        set line_now [mi_wait_for_stop "$testcase: step over $line"]
1342
 
1343
        # We probably want to use 'uplevel' so that statements
1344
        # have direct access to global variables that the
1345
        # main 'exp' file has set up.  But it's not yet clear,
1346
        # will need more experience to be sure.
1347
        eval $statements
1348
    }
1349
}

powered by: WebSVN 2.1.0

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