1 # Copyright 1999-2024 Free Software Foundation, Inc.
3 # This program is free software; you can redistribute it and/or modify
4 # it under the terms of the GNU General Public License as published by
5 # the Free Software Foundation; either version 3 of the License, or
6 # (at your option) any later version.
8 # This program is distributed in the hope that it will be useful,
9 # but WITHOUT ANY WARRANTY; without even the implied warranty of
10 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
11 # GNU General Public License for more details.
13 # You should have received a copy of the GNU General Public License
14 # along with this program. If not, see <http://www.gnu.org/licenses/>.
16 # This file was based on a file written by Fred Fish. (fnf@cygnus.com)
18 # Test setup routines that work with the MI interpreter.
20 load_lib gdb-utils.exp
22 # The variable mi_gdb_prompt is a regexp which matches the gdb mi prompt.
23 # Set it if it is not already set.
25 if {![info exists mi_gdb_prompt]} {
26 set mi_gdb_prompt "\[(\]gdb\[)\] \r\n"
29 global mi_inferior_tty_name
31 # Always points to GDB's main UI spawn ID, even when testing with MI
32 # running on a secondary UI.
33 global gdb_main_spawn_id
35 # Points to the spawn id of the MI channel. When testing with MI
36 # running as the primary/main UI, this is the same as
37 # gdb_main_spawn_id, but will be different when testing with MI
38 # running on a secondary UI.
43 set thread_selected_re "=thread-selected,id=\"\[0-9\]+\"\r\n"
44 set gdbindex_warning_re "&\"warning: Skipping \[^\r\n\]+ \.gdb_index section in \[^\r\n\]+\"\r\n(?:&\"\\\\n\"\r\n)?"
45 set library_loaded_re "=library-loaded\[^\n\]+\"\r\n(?:$gdbindex_warning_re)?"
46 set breakpoint_re "=(?:breakpoint-created|breakpoint-deleted)\[^\n\]+\"\r\n"
49 # mi_gdb_exit -- exit the GDB, killing the target program if necessary
52 catch mi_uncatched_gdb_exit
55 proc mi_uncatched_gdb_exit {} {
57 global INTERNAL_GDBFLAGS GDBFLAGS
58 global gdb_spawn_id gdb_main_spawn_id
59 global mi_spawn_id inferior_spawn_id
64 if { [info procs sid_exit] != "" } {
68 if ![info exists gdb_spawn_id] {
72 verbose "Quitting $GDB $INTERNAL_GDBFLAGS $GDBFLAGS $MIFLAGS"
74 if { [is_remote host] && [board_info host exists fileid] } {
75 send_gdb "999-gdb-exit\n"
81 -re "Undefined command.*$gdb_prompt $" {
85 -re "DOSEXIT code" { }
86 -re "\r\n999\\^exit\r\n" { }
90 # Switch back to the main spawn id, so that remote_close below
91 # closes it, and not a secondary channel. Closing a secondary
92 # channel does not make GDB exit.
93 if {$gdb_spawn_id != $gdb_main_spawn_id} {
94 switch_gdb_spawn_id $gdb_main_spawn_id
97 # Close secondary MI channel, if there's one.
98 if {$mi_spawn_id != $gdb_main_spawn_id} {
102 if ![is_remote host] {
106 unset gdb_main_spawn_id
108 unset inferior_spawn_id
111 # Create the PTY for the inferior process and tell GDB about it.
113 proc mi_create_inferior_pty {} {
115 global inferior_spawn_id
116 global mi_inferior_tty_name
119 set inferior_spawn_id $spawn_id
120 set tty_name $spawn_out(slave,name)
121 set mi_inferior_tty_name $tty_name
123 send_gdb "102-inferior-tty-set $tty_name\n"
125 -re ".*102\\\^done\r\n$mi_gdb_prompt$" {
126 verbose "redirect inferior output to new terminal device."
129 warning "Couldn't redirect inferior output." 2
134 # Create a new pty, and reate a new MI UI (using the new-ui command) on it.
136 # Return a list with the spawn id for that pty and the pty file name.
138 proc create_mi_ui {} {
140 set tty_name $spawn_out(slave,name)
141 gdb_test_multiple "new-ui mi $tty_name" "new-ui" {
142 -re "New UI allocated\r\n$::gdb_prompt $" {
146 return [list $spawn_id $tty_name]
150 # Like default_mi_gdb_start below, but the MI is created as a separate
151 # ui in a new tty. The global MI_SPAWN_ID is updated to point at the
152 # new tty created for the MI interface. The global GDB_MAIN_SPAWN_ID
153 # is updated to the current value of the global GDB_SPAWN_ID.
155 proc mi_gdb_start_separate_mi_tty { { flags {} } } {
156 global gdb_prompt mi_gdb_prompt
158 global gdb_spawn_id gdb_main_spawn_id mi_spawn_id
159 global inferior_spawn_id
161 set separate_inferior_pty 0
163 foreach flag $flags {
164 if {$flag == "separate-inferior-tty"} {
165 set separate_inferior_pty 1
171 # Create the new PTY for the MI UI.
172 lassign [create_mi_ui] mi_spawn_id mi_tty_name
174 # Switch to the MI channel.
175 set gdb_main_spawn_id $gdb_spawn_id
176 switch_gdb_spawn_id $mi_spawn_id
178 # Consume pending output and MI prompt.
180 -re "$mi_gdb_prompt$" {
183 perror "MI channel failed"
189 if {$separate_inferior_pty} {
190 mi_create_inferior_pty
199 # default_mi_gdb_start [FLAGS] -- start gdb running, default procedure
201 # FLAGS is a list of flags, each flag is a string.
203 # If "separate-inferior-tty" is specified, the inferior works with
206 # If "separate-mi-tty" is specified, the gdb starts in CLI mode, with
207 # MI running on a secondary UI, on its own tty.
209 # When running over NFS, particularly if running many simultaneous
210 # tests on different hosts all using the same server, things can
211 # get really slow. Give gdb at least 3 minutes to start up.
213 proc default_mi_gdb_start { { flags {} } } {
216 global INTERNAL_GDBFLAGS GDBFLAGS
220 global gdb_spawn_id gdb_main_spawn_id inferior_spawn_id mi_spawn_id
222 global FORCE_SEPARATE_MI_TTY
224 # Keep track of the number of times GDB has been launched.
230 if {[info exists FORCE_SEPARATE_MI_TTY]} {
231 set separate_mi_pty $FORCE_SEPARATE_MI_TTY
233 set separate_mi_pty 0
236 set separate_inferior_pty 0
238 foreach flag $flags {
239 if {$flag == "separate-mi-tty"} {
240 set separate_mi_pty 1
241 } elseif {$flag == "separate-inferior-tty"} {
242 set separate_inferior_pty 1
246 if {$separate_mi_pty} {
247 return [mi_gdb_start_separate_mi_tty $flags]
250 # Set the default value, it may be overriden later by specific testfile.
251 set use_gdb_stub [target_info exists use_gdb_stub]
254 if { [info procs sid_start] != "" } {
255 verbose "Spawning SID"
259 if [info exists gdb_spawn_id] {
263 save_vars { GDBFLAGS } {
264 append GDBFLAGS " $MIFLAGS"
273 -re "~\"GNU.*\r\n~\".*$mi_gdb_prompt$" {
274 # We have a new format mi startup prompt.
275 verbose "GDB initialized."
277 -re "^(=\[^\r\n\]*\r\n)*$mi_gdb_prompt$" {
279 verbose "GDB initialized."
281 -re ".*unrecognized option.*for a complete list of options." {
282 untested "skip mi tests (not compiled with mi support)."
287 -re ".*Interpreter `mi' unrecognized." {
288 untested "skip mi tests (not compiled with mi support)."
294 perror "(timeout) GDB never initialized after 10 seconds."
300 set gdb_main_spawn_id $gdb_spawn_id
301 set mi_spawn_id $gdb_spawn_id
303 # FIXME: mi output does not go through pagers, so these can be removed.
304 # force the height to "unlimited", so no pagers get used
305 send_gdb "100-gdb-set height 0\n"
307 -re ".*100-gdb-set height 0\r\n100\\\^done\r\n$mi_gdb_prompt$" {
308 verbose "Setting height to 0." 2
311 warning "Couldn't set the height to 0"
314 # force the width to "unlimited", so no wraparound occurs
315 send_gdb "101-gdb-set width 0\n"
317 -re ".*101-gdb-set width 0\r\n101\\\^done\r\n$mi_gdb_prompt$" {
318 verbose "Setting width to 0." 2
321 warning "Couldn't set the width to 0."
325 if { $separate_inferior_pty } {
326 mi_create_inferior_pty
329 if {![info exists inferior_spawn_id]} {
330 set inferior_spawn_id $gdb_spawn_id
339 # Overridable function. You can override this function in your
342 proc mi_gdb_start { args } {
343 return [eval default_mi_gdb_start $args]
346 # Many of the tests depend on setting breakpoints at various places and
347 # running until that breakpoint is reached. At times, we want to start
348 # with a clean-slate with respect to breakpoints, so this utility proc
349 # lets us do this without duplicating this code everywhere.
352 proc mi_delete_breakpoints {} {
355 # FIXME: The mi operation won't accept a prompt back and will use the 'all' arg
356 send_gdb "102-break-delete\n"
358 -re "Delete all breakpoints, watchpoints, tracepoints, and catchpoints.*y or n.*$" {
362 -re "102-break-delete\r\n102\\\^done\r\n$mi_gdb_prompt$" {
363 # This happens if there were no breakpoints
365 timeout { perror "Delete all breakpoints, watchpoints, tracepoints, and catchpoints in mi_delete_breakpoints (timeout)" ; return }
368 # The correct output is not "No breakpoints, watchpoints, tracepoints, or catchpoints." but an
369 # empty BreakpointTable. Also, a query is not acceptable with mi.
370 send_gdb "103-break-list\n"
372 -re "103-break-list\r\n103\\\^done,BreakpointTable=\{\}\r\n$mi_gdb_prompt$" {}
373 -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=\\\[\\\]\}\r\n$mi_gdb_prompt$" {}
374 -re "103-break-list\r\n103\\\^doneNo breakpoints, watchpoints, tracepoints, or catchpoints.\r\n\r\n$mi_gdb_prompt$" {warning "Unexpected console text received"}
375 -re "$mi_gdb_prompt$" { perror "Breakpoints not deleted" ; return }
376 -re "Delete all breakpoints, watchpoints, tracepoints, and catchpoints.*or n.*$" {
377 warning "Unexpected prompt for breakpoints deletion"
381 timeout { perror "-break-list (timeout)" ; return }
385 proc mi_gdb_reinitialize_dir { subdir } {
389 if [is_remote host] {
393 send_gdb "104-environment-directory -r\n"
395 -re "104\\\^done,source-path=.*\r\n$mi_gdb_prompt$" {}
396 -re "$mi_gdb_prompt$" {}
397 timeout {error "Dir reinitialization failed (timeout)"}
400 send_gdb "105-environment-directory $subdir\n"
402 -re "Source directories searched.*$mi_gdb_prompt$" {
403 verbose "Dir set to $subdir"
405 -re "105\\\^done.*\r\n$mi_gdb_prompt$" {
406 # FIXME: We return just the prompt for now.
407 verbose "Dir set to $subdir"
408 # perror "Dir \"$subdir\" failed."
413 # Send GDB the "target" command.
414 # FIXME: Some of these patterns are not appropriate for MI. Based on
415 # config/monitor.exp:gdb_target_command.
416 proc mi_gdb_target_cmd { targetname serialport } {
419 set serialport_re [string_to_regexp $serialport]
420 for {set i 1} {$i <= 3} {incr i} {
421 send_gdb "47-target-select $targetname $serialport\n"
423 -re "47\\^connected.*$mi_gdb_prompt" {
424 verbose "Set target to $targetname"
427 -re "unknown host.*$mi_gdb_prompt" {
428 verbose "Couldn't look up $serialport"
430 -re "Couldn't establish connection to remote.*$mi_gdb_prompt$" {
431 verbose "Connection failed"
433 -re "Remote MIPS debugging.*$mi_gdb_prompt$" {
434 verbose "Set target to $targetname"
437 -re "Remote debugging using .*$serialport_re.*$mi_gdb_prompt$" {
438 verbose "Set target to $targetname"
441 -re "Remote target $targetname connected to.*$mi_gdb_prompt$" {
442 verbose "Set target to $targetname"
445 -re "Connected to.*$mi_gdb_prompt$" {
446 verbose "Set target to $targetname"
449 -re "Ending remote.*$mi_gdb_prompt$" { }
450 -re "Connection refused.*$mi_gdb_prompt$" {
451 verbose "Connection refused by remote target. Pausing, and trying again."
455 -re "Non-stop mode requested, but remote does not support non-stop.*$mi_gdb_prompt" {
456 unsupported "non-stop mode not supported"
459 -re "Timeout reading from remote system.*$mi_gdb_prompt$" {
460 verbose "Got timeout error from gdb."
472 # load a file into the debugger (file command only).
473 # return a -1 if anything goes wrong.
475 proc mi_gdb_file_cmd { arg } {
480 global last_loaded_file
481 upvar timeout timeout
483 # GCC for Windows target may create foo.exe given "-o foo".
484 if { ![file exists $arg] && [file exists "$arg.exe"] } {
488 set last_loaded_file $arg
490 if [is_remote host] {
491 set arg [remote_download host $arg]
493 error "download failed"
498 # FIXME: Several of these patterns are only acceptable for console
499 # output. Queries are an error for mi.
500 send_gdb "105-file-exec-and-symbols $arg\n"
502 -re "Reading symbols from.*$mi_gdb_prompt$" {
503 verbose "\t\tLoaded $arg into the $GDB"
506 -re "has no symbol-table.*$mi_gdb_prompt$" {
507 perror "$arg wasn't compiled with \"-g\""
510 -re "Load new symbol table from \".*\".*y or n. $" {
513 -re "Reading symbols from.*$mi_gdb_prompt$" {
514 verbose "\t\tLoaded $arg with new symbol table into $GDB"
518 perror "(timeout) Couldn't load $arg, other program already loaded."
523 -re "No such file or directory.*$mi_gdb_prompt$" {
524 perror "($arg) No such file or directory\n"
527 -re "105-file-exec-and-symbols .*\r\n105\\\^done\r\n$mi_gdb_prompt$" {
528 # We (MI) are just giving the prompt back for now, instead of giving
529 # some acknowledgement.
533 perror "couldn't load $arg into $GDB (timed out)."
537 # This is an attempt to detect a core dump, but seems not to
538 # work. Perhaps we need to match .* followed by eof, in which
539 # gdb_expect does not seem to have a way to do that.
540 perror "couldn't load $arg into $GDB (end of file)."
547 # connect to the target and download a file, if necessary.
548 # return a -1 if anything goes wrong.
550 proc mi_gdb_target_load { } {
556 if [target_info exists gdb_load_timeout] {
557 set loadtimeout [target_info gdb_load_timeout]
562 if { [info procs gdbserver_gdb_load] != "" } {
563 mi_gdb_test "kill" ".*" ""
564 if { [catch gdbserver_gdb_load res] == 1 } {
568 set protocol [lindex $res 0]
569 set gdbport [lindex $res 1]
571 if { [mi_gdb_target_cmd $protocol $gdbport] != 0 } {
574 } elseif { [info procs send_target_sid] != "" } {
575 # For SID, things get complex
578 -re ".*$mi_gdb_prompt$"
581 gdb_expect $loadtimeout {
582 -re "\\^done.*$mi_gdb_prompt$" {
585 perror "Unable to connect to SID target (timeout)"
589 send_gdb "48-target-download\n"
590 gdb_expect $loadtimeout {
591 -re "48\\^done.*$mi_gdb_prompt$" {
594 perror "Unable to download to SID target (timeout)"
598 } elseif { [target_info protocol] == "sim" } {
599 set target_sim_options "[board_info target gdb,target_sim_options]"
600 # For the simulator, just connect to it directly.
601 send_gdb "47-target-select sim $target_sim_options\n"
602 gdb_expect $loadtimeout {
603 -re "47\\^connected.*$mi_gdb_prompt$" {
606 perror "Unable to select sim target (timeout)"
610 send_gdb "48-target-download\n"
611 gdb_expect $loadtimeout {
612 -re "48\\^done.*$mi_gdb_prompt$" {
615 perror "Unable to download to sim target (timeout)"
619 } elseif { [target_info gdb_protocol] == "remote" } {
621 if { [mi_gdb_target_cmd "remote" [target_info netport]] != 0 } {
622 perror "Unable to connect to remote target"
625 send_gdb "48-target-download\n"
626 gdb_expect $loadtimeout {
627 -re "48\\^done.*$mi_gdb_prompt$" {
630 perror "Unable to download to remote target (timeout)"
639 # load a file into the debugger.
640 # return a -1 if anything goes wrong.
642 proc mi_gdb_load { arg } {
644 return [mi_gdb_file_cmd $arg]
649 # Return true if symbols were read in using -readnow. Otherwise,
652 proc mi_readnow { args } {
653 # Just defer to gdb.exp.
657 # mi_gdb_test COMMAND [PATTERN [MESSAGE [IPATTERN]]] -- send a command to gdb;
660 # COMMAND is the command to execute, send to GDB with send_gdb. If
661 # this is the null string no command is sent.
662 # PATTERN is the pattern to match for a PASS, and must NOT include
663 # the \r\n sequence immediately before the gdb prompt.
664 # If not specified, .* is used.
665 # MESSAGE is the message to be printed. (If this is the empty string,
666 # then sometimes we don't call pass or fail at all; I don't
667 # understand this at all.)
668 # If not specified, COMMAND is used.
669 # IPATTERN is the pattern to match for the inferior's output. This parameter
670 # is optional. If present, it will produce a PASS if the match is
671 # successful, and a FAIL if unsuccessful.
674 # 1 if the test failed,
675 # 0 if the test passes,
676 # -1 if there was an internal error.
678 proc mi_gdb_test { args } {
681 global GDB expect_out
682 global inferior_exited_re async
683 upvar timeout timeout
685 if {[llength $args] >= 1} {
686 set command [lindex $args 0]
688 error "Not enough arguments in mi_gdb_test"
691 if {[llength $args] >= 2} {
692 set pattern [lindex $args 1]
697 if {[llength $args] >= 3} {
698 set message [lindex $args 2]
703 if [llength $args]==4 {
704 set ipattern [lindex $args 3]
707 if [llength $args]==5 {
708 set question_string [lindex $args 3]
709 set response_string [lindex $args 4]
711 set question_string "^FOOBAR$"
714 if { [llength $args] >= 6 } {
715 error "Too many arguments in mi_gdb_test"
719 send_user "Sending \"$command\" to gdb\n"
720 send_user "Looking to match \"$pattern\"\n"
721 send_user "Message is \"$message\"\n"
725 set string "${command}\n"
726 set string_regex [string_to_regexp $command]
728 if { $command != "" } {
729 while { "$string" != "" } {
730 set foo [string first "\n" "$string"]
731 set len [string length "$string"]
732 if { $foo < [expr $len - 1] } {
733 set str [string range "$string" 0 $foo]
734 if { [send_gdb "$str"] != "" } {
735 perror "Couldn't send $command to GDB."
741 set string [string range "$string" [expr $foo + 1] end]
746 if { "$string" != "" } {
747 if { [send_gdb "$string"] != "" } {
748 perror "Couldn't send $command to GDB."
753 if [info exists timeout] {
757 if [info exists timeout] {
764 # With $prompt_re "" there may come arbitrary asynchronous response
765 # from the previous command, before or after $string_regex.
766 set string_regex ".*"
768 verbose -log "Expecting: ^($string_regex\[\r\n\]+)?($pattern\[\r\n\]+$mi_gdb_prompt\[ \]*)"
770 -re "\\*\\*\\* DOSEXIT code.*" {
771 if { $message != "" } {
776 -re "Ending remote debugging.*$mi_gdb_prompt\[ \]*$" {
778 warning "Can`t communicate to remote target."
784 -re "^($string_regex\[\r\n\]+)?($pattern\[\r\n\]+$mi_gdb_prompt\[ \]*)" {
785 # At this point, $expect_out(1,string) is the MI input command.
786 # and $expect_out(2,string) is the MI output command.
787 # If $expect_out(1,string) is "", then there was no MI input command here.
789 # NOTE, there is no trailing anchor because with GDB/MI,
790 # asynchronous responses can happen at any point, causing more
791 # data to be available. Normally an anchor is used to make
792 # sure the end of the output is matched, however, $mi_gdb_prompt
793 # is just as good of an anchor since mi_gdb_test is meant to
794 # match a single mi output command. If a second GDB/MI output
795 # response is sent, it will be in the buffer for the next
796 # time mi_gdb_test is called.
797 if {![string match "" $message]} {
802 -re "(${question_string})$" {
803 send_gdb "$response_string\n"
806 -re "Undefined.* command:.*$mi_gdb_prompt\[ \]*$" {
807 perror "Undefined command \"$command\"."
811 -re "Ambiguous command.*$mi_gdb_prompt\[ \]*$" {
812 perror "\"$command\" is not a unique command name."
816 -re "$inferior_exited_re with code \[0-9\]+.*$mi_gdb_prompt\[ \]*$" {
817 if {![string match "" $message]} {
818 set errmsg "$message (the program exited)"
820 set errmsg "$command (the program exited)"
825 -re "The program is not being run.*$mi_gdb_prompt\[ \]*$" {
826 if {![string match "" $message]} {
827 set errmsg "$message (the program is no longer running)"
829 set errmsg "$command (the program is no longer running)"
834 -re "(.*$mi_gdb_prompt\[ \]*)$" {
835 if {![string match "" $message]} {
836 fail "$message (unexpected output)"
842 perror "Window too small."
846 perror "Process no longer exists"
847 if { $message != "" } {
853 perror "internal buffer is full."
857 if {![string match "" $message]} {
858 fail "$message (timeout)"
864 # If the GDB output matched, compare the inferior output.
865 if { $result == 0 } {
866 if [ info exists ipattern ] {
867 if { ![target_info exists gdb,noinferiorio] } {
868 global gdb_spawn_id inferior_spawn_id
870 set sid "$inferior_spawn_id $gdb_spawn_id"
872 -i "$sid" -re "$ipattern" {
873 pass "$message inferior output"
876 fail "$message inferior output (timeout)"
881 unsupported "$message inferior output"
889 # Collect output sent to the console output stream until UNTIL is
890 # seen. UNTIL is a regular expression. MESSAGE is the message to be
891 # printed in case of timeout.
893 proc mi_gdb_expect_cli_output {until message} {
897 -re "~\"(\[^\r\n\]+)\"\r\n" {
898 append output $expect_out(1,string)
901 -notransfer -re "$until" {
905 fail "$message (timeout)"
914 # MI run command. (A modified version of gdb_run_cmd)
917 # In patterns, the newline sequence ``\r\n'' is matched explicitly as
918 # ``.*$'' could swallow up output that we attempt to match elsewhere.
920 # Send the command to run the test program.
922 # If USE_MI_COMMAND is true, the "-exec-run" command is used.
923 # Otherwise, the "run" (CLI) command is used. If the global USE_GDB_STUB is
924 # true, -exec-continue and continue are used instead of their run counterparts.
926 # ARGS is passed as argument to the command used to run the test program.
927 # Beware that arguments to "-exec-run" do not have the same semantics as
928 # arguments to the "run" command, so USE_MI_COMMAND influences the meaning
929 # of ARGS. If USE_MI_COMMAND is true, they are arguments to -exec-run.
930 # If USE_MI_COMMAND is false, they are effectively arguments passed
931 # to the test program. If the global USE_GDB_STUB is true, ARGS is not used.
932 proc mi_run_cmd_full {use_mi_command args} {
933 global mi_gdb_prompt use_gdb_stub
934 global thread_selected_re
935 global library_loaded_re
937 if {$use_mi_command} {
938 set run_prefix "220-exec-"
945 foreach command [gdb_init_commands] {
946 send_gdb "$command\n"
948 -re "$mi_gdb_prompt$" { }
950 unresolved "gdb_init_command for target failed"
956 if { [mi_gdb_target_load] < 0 } {
961 if [target_info exists gdb,do_reload_on_run] {
962 send_gdb "${run_prefix}continue\n"
964 -re "${run_match}\\^running\[\r\n\]+\\*running,thread-id=\"\[^\"\]+\"\r\n$mi_gdb_prompt" {}
965 -re "${run_match}\\^error.*$mi_gdb_prompt" {return -1}
971 if [target_info exists gdb,start_symbol] {
972 set start [target_info gdb,start_symbol]
977 # HACK: Should either use 000-jump or fix the target code
978 # to better handle RUN.
979 send_gdb "jump *$start\n"
980 warning "Using CLI jump command, expect run-to-main FAIL"
982 -re "&\"jump \\*${start}\\\\n\"\[\r\n\]+~\"Continuing at 0x\[0-9A-Fa-f\]+\.\\\\n\"\[\r\n\]+\\^running\[\r\n\]+\\*running,thread-id=\"\[^\"\]+\"\[\r\n\]+${mi_gdb_prompt}" {}
984 unresolved "unable to start target"
991 send_gdb "${run_prefix}run $args\n"
993 -re "${run_match}\\^running\r\n(\\*running,thread-id=\"\[^\"\]+\"\r\n|=thread-created,id=\"1\",group-id=\"\[0-9\]+\"\r\n)*(${library_loaded_re})*(${thread_selected_re})?${mi_gdb_prompt}" {
995 -re "\\^error,msg=\"The target does not support running in non-stop mode.\"" {
996 unsupported "non-stop mode not supported"
1000 unresolved "unable to start target"
1004 # NOTE: Shortly after this there will be a ``000*stopped,...(gdb)''
1009 # A wrapper for mi_run_cmd_full which uses -exec-run and
1010 # -exec-continue, as appropriate. ARGS are passed verbatim to
1012 proc mi_run_cmd {args} {
1013 return [eval mi_run_cmd_full 1 $args]
1016 # A wrapper for mi_run_cmd_full which uses the CLI commands 'run' and
1017 # 'continue', as appropriate. ARGS are passed verbatim to
1019 proc mi_run_with_cli {args} {
1020 return [eval mi_run_cmd_full 0 $args]
1023 # Starts fresh GDB binary and loads an optional executable into GDB.
1024 # Usage: mi_clean_restart [EXECUTABLE]
1025 # EXECUTABLE is the basename of the binary.
1026 # Return -1 if starting gdb or loading the executable failed.
1028 proc mi_clean_restart {{executable ""} {flags {}}} {
1036 # This is a clean restart, so reset error and warning count.
1040 if {[mi_gdb_start $flags]} {
1044 mi_gdb_reinitialize_dir $srcdir/$subdir
1046 if {$executable != ""} {
1047 set binfile [standard_output_file ${executable}]
1048 return [mi_gdb_load ${binfile}]
1054 # Just like gdb's "runto" proc, it will run the target to a given
1055 # function. The big difference here between mi_runto and mi_execute_to
1056 # is that mi_execute_to must have the inferior running already. This
1057 # proc will (like gdb's runto) (re)start the inferior, too.
1059 # FUNC is the linespec of the place to stop (it inserts a breakpoint here).
1061 # -1 if failed, timedout
1064 # Supported options:
1066 # -qualified -- pass --qualified to -break-insert
1067 # -pending -- pass -f to -break-insert to create a pending
1070 proc mi_runto_helper {func run_or_continue args} {
1071 global mi_gdb_prompt expect_out
1072 global hex decimal fullname_syntax
1074 parse_args {{qualified} {pending}}
1076 set test "mi runto $func"
1078 set bp [mi_make_breakpoint_pending -type breakpoint -disp del]
1080 set bp [mi_make_breakpoint -type breakpoint -disp del \
1081 -func $func\(\\\(.*\\\)\)?]
1086 lappend extra_opts "--qualified"
1089 lappend extra_opts "-f"
1090 # MI prints "Function FUNC not defined", "No line NNN in current
1091 # file.", etc. to the CLI stream.
1092 set extra_output "&\"\[^\r\n\]+\"\r\n"
1095 mi_gdb_test "200-break-insert [join $extra_opts " "] -t $func" "${extra_output}200\\^done,$bp" \
1096 "breakpoint at $func"
1098 if {$run_or_continue == "run"} {
1099 if { [mi_run_cmd] < 0 } {
1103 mi_send_resuming_command "exec-continue" "$test"
1106 mi_expect_stop "breakpoint-hit" $func ".*" ".*" "\[0-9\]+" { "" "disp=\"del\"" } $test
1109 proc mi_runto {func args} {
1110 return [mi_runto_helper $func "run" {*}$args]
1113 # Just like runto_main but works with the MI interface.
1115 proc mi_runto_main {} {
1116 return [mi_runto_helper "main" "run" -qualified]
1119 # Next to the next statement
1120 # For return values, see mi_execute_to_helper
1122 proc mi_next { test } {
1123 return [mi_next_to {.*} {.*} {.*} {.*} $test]
1127 # Step to the next statement
1128 # For return values, see mi_execute_to_helper
1130 proc mi_step { test } {
1131 return [mi_step_to {.*} {.*} {.*} {.*} $test]
1136 proc mi_detect_async {} {
1138 global mi_gdb_prompt
1140 send_gdb "show mi-async\n"
1143 -re "asynchronous mode is on...*$mi_gdb_prompt$" {
1146 -re ".*$mi_gdb_prompt$" {
1156 # Wait for MI *stopped notification to appear.
1157 # The REASON, FUNC, ARGS, FILE and LINE are regular expressions
1158 # to match against whatever is output in *stopped. FILE may also match
1159 # filename of a file without debug info. ARGS should not include [] the
1160 # list of argument is enclosed in, and other regular expressions should
1161 # not include quotes.
1162 # EXTRA can be a list of one, two or three elements.
1163 # The first element is the regular expression
1164 # for output expected right after *stopped, and before GDB prompt.
1165 # The third element is the regular expression for the locno
1166 # right after bkptno field. The locno regex should not include
1167 # the comma separating it from the following fields.
1169 # When we fail to match output at all, -1 is returned. If FILE does
1170 # match and the target system has no debug info for FILE return 0.
1171 # Otherwise, the line at which we stop is returned. This is useful when
1172 # exact line is not possible to specify for some reason -- one can pass
1173 # the .* or "\[0-9\]*" regexps for line, and then check the line
1176 # Do not pass .* for any argument if you are expecting more than one stop.
1177 proc mi_expect_stop { reason func args file line extra test } {
1179 global mi_gdb_prompt
1182 global fullname_syntax
1184 global thread_selected_re
1185 global breakpoint_re
1189 set after_stopped ""
1192 if { [llength $extra] == 3 } {
1193 set after_stopped [lindex $extra 0]
1194 set after_reason [lindex $extra 1]
1195 set after_reason "${after_reason},"
1196 set locno [lindex $extra 2]
1197 set locno "${locno},"
1198 } elseif { [llength $extra] == 2 } {
1199 set after_stopped [lindex $extra 0]
1200 set after_reason [lindex $extra 1]
1201 set after_reason "${after_reason},"
1202 } elseif { [llength $extra] == 1 } {
1203 set after_stopped [lindex $extra 0]
1209 set prompt_re "$mi_gdb_prompt$"
1212 if { $reason == "really-no-reason" } {
1214 -re "\\*stopped\r\n$prompt_re" {
1218 fail "$test (timeout)"
1224 if { $reason == "exited-normally" } {
1227 -re "\\*stopped,reason=\"exited-normally\"\r\n$prompt_re" {
1230 -re ".*$mi_gdb_prompt$" {fail "continue to end (2)"}
1232 fail "$test (timeout)"
1237 if { $reason == "exited" } {
1239 -re "\\*stopped,reason=\"exited\",exit-code=\"\[0-7\]+\"\r\n$prompt_re" {
1242 -re ".*$mi_gdb_prompt$" {
1243 fail "$test (inferior not stopped)"
1246 fail "$test (timeout)"
1252 if { $reason == "solib-event" } {
1253 set pattern "\\*stopped,reason=\"solib-event\",thread-id=\"$decimal\",stopped-threads=$any\r\n($thread_selected_re|$breakpoint_re)*$prompt_re"
1254 verbose -log "mi_expect_stop: expecting: $pattern"
1260 fail "$test (timeout)"
1266 set args "\\\[$args\\\]"
1270 if { $reason == "breakpoint-hit" } {
1271 set bn {bkptno="[0-9]+",}
1272 set bn "${bn}${locno}"
1273 } elseif { $reason == "solib-event" } {
1275 } elseif { $reason == "exception-caught" } {
1276 set ebn {bkptno="[0-9]+",}
1277 set ebn "${ebn}${locno}"
1279 set reason "breakpoint-hit"
1283 if { $reason != "" } {
1284 if { [regexp "\"" $reason] } {
1285 set r "reason=$reason,"
1287 set r "reason=\"$reason\","
1294 verbose -log "mi_expect_stop: expecting: \\*stopped,${ebn}${r}${a}${bn}frame=\{addr=\"$hex\",func=\"$func\",args=$args,(?:file=\"$any$file\",fullname=\"${fullname_syntax}$file\",line=\"$line\",arch=\"$any\"|from=\"$file\")\}$after_stopped,thread-id=\"$decimal\",stopped-threads=$any\r\n($thread_selected_re|$breakpoint_re)*$prompt_re"
1297 -re "\\*stopped,${ebn}${r}${a}${bn}frame=\{addr=\"$hex\",func=\"$func\",args=$args,(?:file=\"$any$file\",fullname=\"${fullname_syntax}$file\",line=\"($line)\",arch=\"$any\"|from=\"$file\")\}$after_stopped,thread-id=\"$decimal\",stopped-threads=$any\r\n($thread_selected_re|$breakpoint_re)*$prompt_re" {
1299 if {[array names expect_out "2,string"] != ""} {
1300 return $expect_out(2,string)
1302 # No debug info available but $file does match.
1305 -re "\\*stopped,${ebn}${r}${a}${bn}frame=\{addr=\"$hex\",func=\"$any\",args=\[\\\[\{\]$any\[\\\]\}\],file=\"$any\",fullname=\"${fullname_syntax}$any\",line=\"\[0-9\]*\",arch=\"$any\"\}$after_stopped,thread-id=\"$decimal\",stopped-threads=$any\r\n($thread_selected_re|$breakpoint_re)*$prompt_re" {
1306 verbose -log "got $expect_out(buffer)"
1307 fail "$test (stopped at wrong place)"
1310 -re ".*\r\n$mi_gdb_prompt$" {
1311 verbose -log "got $expect_out(buffer)"
1312 fail "$test (unknown output after running)"
1316 fail "$test (timeout)"
1322 # Wait for MI *stopped notification related to an interrupt request to
1324 proc mi_expect_interrupt { test } {
1325 global mi_gdb_prompt
1332 set prompt_re "$mi_gdb_prompt"
1335 set r_nonstop "reason=\"signal-received\",signal-name=\"0\",signal-meaning=\"Signal 0\""
1336 set r_allstop "reason=\"signal-received\",signal-name=\"SIGINT\",signal-meaning=\"Interrupt\""
1337 set r "(${r_nonstop}|${r_allstop})"
1340 # A signal can land anywhere, just ignore the location
1341 verbose -log "mi_expect_interrupt: expecting: \\*stopped,${r}$any\r\n$prompt_re"
1343 -re "\\*stopped,${r}$any\r\n$prompt_re" {
1347 -re ".*\r\n$mi_gdb_prompt" {
1348 verbose -log "got $expect_out(buffer)"
1349 fail "$test (unknown output after running)"
1353 fail "$test (timeout)"
1359 # cmd should not include the number or newline (i.e. "exec-step 3", not
1360 # "220-exec-step 3\n"
1362 # Can not match -re ".*\r\n${mi_gdb_prompt}", because of false positives
1363 # after the first prompt is printed.
1365 proc mi_execute_to { cmd reason func args file line extra test } {
1366 mi_send_resuming_command "$cmd" "$test"
1367 set r [mi_expect_stop $reason $func $args $file $line $extra $test]
1371 proc mi_next_to { func args file line test } {
1372 mi_execute_to "exec-next" "end-stepping-range" "$func" "$args" \
1373 "$file" "$line" "" "$test"
1376 proc mi_step_to { func args file line test } {
1377 mi_execute_to "exec-step" "end-stepping-range" "$func" "$args" \
1378 "$file" "$line" "" "$test"
1381 proc mi_finish_to { func args file line result ret test } {
1382 mi_execute_to "exec-finish" "function-finished" "$func" "$args" \
1384 ",gdb-result-var=\"$result\",return-value=\"$ret\"" \
1388 proc mi_continue_to {func} {
1389 mi_runto_helper $func "continue"
1392 # Creates a breakpoint and checks the reported fields are as expected.
1393 # This procedure takes the same options as mi_make_breakpoint and
1394 # returns the breakpoint regexp from that procedure.
1396 proc mi_create_breakpoint {location test args} {
1397 set bp [eval mi_make_breakpoint $args]
1398 mi_gdb_test "222-break-insert $location" "222\\^done,$bp" $test
1402 # Like mi_create_breakpoint, but creates a breakpoint with multiple
1403 # locations using mi_make_breakpoint_multi instead.
1405 proc mi_create_breakpoint_multi {location test args} {
1406 set bp [eval mi_make_breakpoint_multi $args]
1407 mi_gdb_test "222-break-insert $location" "222\\^done,$bp" $test
1411 # Like mi_create_breakpoint, but creates a pending breakpoint.
1413 proc mi_create_breakpoint_pending {location test args} {
1414 set bp [eval mi_make_breakpoint_pending $args]
1415 mi_gdb_test "222-break-insert $location" ".*\r\n222\\^done,$bp" $test
1419 # Creates varobj named NAME for EXPRESSION.
1420 # Name cannot be "-".
1421 proc mi_create_varobj { name expression testname } {
1422 mi_gdb_test "-var-create $name * $expression" \
1423 "\\^done,name=\"$name\",numchild=\"\[0-9\]+\",value=\".*\",type=.*,has_more=\"0\"" \
1427 proc mi_create_floating_varobj { name expression testname } {
1428 mi_gdb_test "-var-create $name @ $expression" \
1429 "\\^done,name=\"$name\",numchild=\"\(-1\|\[0-9\]+\)\",value=\".*\",type=.*" \
1434 # Same as mi_create_varobj, but also checks the reported type
1436 proc mi_create_varobj_checked { name expression type testname } {
1437 mi_gdb_test "-var-create $name * $expression" \
1438 "\\^done,name=\"$name\",numchild=\"\[0-9\]+\",value=\".*\",type=\"$type\".*" \
1442 # Same as mi_create_floating_varobj, but assumes the test is creating
1443 # a dynamic varobj that has children. The "value" and "has_more"
1444 # attributes are checked.
1445 proc mi_create_dynamic_varobj {name expression value has_more testname} {
1446 mi_gdb_test "-var-create $name @ $expression" \
1447 "\\^done,name=\"$name\",numchild=\"0\",value=\"$value\",type=.*,has_more=\"${has_more}\"" \
1451 # Deletes the specified NAME.
1452 proc mi_delete_varobj { name testname } {
1453 mi_gdb_test "-var-delete $name" \
1454 "\\^done,ndeleted=.*" \
1458 # Updates varobj named NAME and checks that all varobjs in EXPECTED
1459 # are reported as updated, and no other varobj is updated.
1460 # Assumes that no varobj is out of scope and that no varobj changes
1462 proc mi_varobj_update { name expected testname } {
1463 set er "\\^done,changelist=\\\["
1465 foreach item $expected {
1466 set v "{name=\"$item\",in_scope=\"true\",type_changed=\"false\",has_more=\".\"}"
1476 verbose -log "Expecting: $er" 2
1477 mi_gdb_test "-var-update $name" $er $testname
1480 proc mi_varobj_update_with_child_type_change { name child_name new_type new_children testname } {
1481 set v "{name=\"$child_name\",in_scope=\"true\",type_changed=\"true\",new_type=\"$new_type\",new_num_children=\"$new_children\",has_more=\".\"}"
1482 set er "\\^done,changelist=\\\[$v\\\]"
1483 verbose -log "Expecting: $er"
1484 mi_gdb_test "-var-update $name" $er $testname
1487 proc mi_varobj_update_with_type_change { name new_type new_children testname } {
1488 mi_varobj_update_with_child_type_change $name $name $new_type $new_children $testname
1491 # A helper that turns a key/value list into a regular expression
1492 # matching some MI output.
1493 proc mi_varobj_update_kv_helper {list} {
1496 foreach {key value} $list {
1501 if {$key == "new_children"} {
1502 append rx "$key=\\\[$value\\\]"
1504 append rx "$key=\"$value\""
1510 # A helper for mi_varobj_update_dynamic that computes a match
1511 # expression given a child list.
1512 proc mi_varobj_update_dynamic_helper {children} {
1516 foreach child $children {
1522 append crx [mi_varobj_update_kv_helper $child]
1529 # Update a dynamic varobj named NAME. CHILDREN is a list of children
1530 # that have been updated; NEW_CHILDREN is a list of children that were
1531 # added to the primary varobj. Each child is a list of key/value
1532 # pairs that are expected. SELF is a key/value list holding
1533 # information about the varobj itself. TESTNAME is the name of the
1535 proc mi_varobj_update_dynamic {name testname self children new_children} {
1536 if {[llength $new_children]} {
1537 set newrx [mi_varobj_update_dynamic_helper $new_children]
1538 lappend self new_children $newrx
1540 set selfrx [mi_varobj_update_kv_helper $self]
1541 set crx [mi_varobj_update_dynamic_helper $children]
1543 set er "\\^done,changelist=\\\[\{name=\"$name\",in_scope=\"true\""
1544 append er ",$selfrx\}"
1550 verbose -log "Expecting: $er"
1551 mi_gdb_test "-var-update $name" $er $testname
1554 proc mi_check_varobj_value { name value testname } {
1556 mi_gdb_test "-var-evaluate-expression $name" \
1557 "\\^done,value=\"$value\"" \
1561 # Helper proc which constructs a child regexp for
1562 # mi_list_varobj_children and mi_varobj_update_dynamic.
1563 proc mi_child_regexp {children add_child} {
1572 foreach item $children {
1574 set name [lindex $item 0]
1575 set exp [lindex $item 1]
1576 set numchild [lindex $item 2]
1577 if {[llength $item] == 5} {
1578 set type [lindex $item 3]
1579 set value [lindex $item 4]
1581 lappend children_exp\
1582 "$pre{name=\"$name\",exp=\"$exp\",numchild=\"$numchild\",value=\"$value\",type=\"$type\"(,thread-id=\"\[0-9\]+\")?}"
1583 } elseif {[llength $item] == 4} {
1584 set type [lindex $item 3]
1586 lappend children_exp\
1587 "$pre{name=\"$name\",exp=\"$exp\",numchild=\"$numchild\",type=\"$type\"(,thread-id=\"\[0-9\]+\")?}"
1589 lappend children_exp\
1590 "$pre{name=\"$name\",exp=\"$exp\",numchild=\"$numchild\"(,thread-id=\"\[0-9\]+\")?}"
1593 return [join $children_exp ","]
1596 # Check the results of the:
1598 # -var-list-children VARNAME
1600 # command. The CHILDREN parement should be a list of lists.
1601 # Each inner list can have either 3 or 4 elements, describing
1602 # fields that gdb is expected to report for child variable object,
1603 # in the following order
1607 # - Number of children
1610 # If inner list has 3 elements, the gdb is expected to output no
1611 # type for a child and no value.
1613 # If the inner list has 4 elements, gdb output is expected to
1616 proc mi_list_varobj_children { varname children testname } {
1617 mi_list_varobj_children_range $varname "" "" [llength $children] $children \
1621 # Like mi_list_varobj_children, but sets a subrange. NUMCHILDREN is
1622 # the total number of children.
1623 proc mi_list_varobj_children_range {varname from to numchildren children testname} {
1625 if {[llength $varname] == 2} {
1626 set options [lindex $varname 1]
1627 set varname [lindex $varname 0]
1630 set children_exp_j [mi_child_regexp $children 1]
1632 set expected "\\^done,numchild=\".*\",children=\\\[$children_exp_j.*\\\]"
1634 set expected "\\^done,numchild=\"0\""
1638 append expected ",has_more=\"0\""
1639 } elseif {$to >= 0 && $numchildren > $to} {
1640 append expected ",has_more=\"1\""
1642 append expected ",has_more=\"0\""
1645 verbose -log "Expecting: $expected"
1647 mi_gdb_test "-var-list-children $options $varname $from $to" \
1651 # Verifies that variable object VARNAME has NUMBER children,
1652 # where each one is named $VARNAME.<index-of-child> and has type TYPE.
1653 proc mi_list_array_varobj_children { varname number type testname } {
1654 mi_list_array_varobj_children_with_index $varname $number 0 $type $testname
1657 # Same as mi_list_array_varobj_children, but allowing to pass a start index
1659 proc mi_list_array_varobj_children_with_index { varname number start_index \
1662 set index $start_index
1663 for {set i 0} {$i < $number} {incr i} {
1664 lappend t [list $varname.$index $index 0 $type]
1667 mi_list_varobj_children $varname $t $testname
1670 # A list of two-element lists. First element of each list is
1671 # a Tcl statement, and the second element is the line
1672 # number of source C file where the statement originates.
1673 set mi_autotest_data ""
1674 # The name of the source file for autotesting.
1675 set mi_autotest_source ""
1677 # Prepares for running inline tests in FILENAME.
1678 # See comments for mi_run_inline_test for detailed
1679 # explanation of the idea and syntax.
1680 proc mi_prepare_inline_tests { filename } {
1684 global mi_autotest_source
1685 global mi_autotest_data
1687 set mi_autotest_data {}
1689 set mi_autotest_source $filename
1691 if {![regexp "^/" "$filename"]} {
1692 set filename "$srcdir/$subdir/$filename"
1695 set chan [open $filename]
1696 set content [read $chan]
1699 set start [string first "/*:" $content]
1701 set end [string first ":*/" $content]
1703 error "Unterminated special comment in $filename"
1706 set prefix [string range $content 0 $start]
1707 set prefix_newlines [count_newlines $prefix]
1709 set line_number [expr $line_number+$prefix_newlines]
1710 set comment_line $line_number
1712 set comment [string range $content [expr $start+3] [expr $end-1]]
1714 set comment_newlines [count_newlines $comment]
1715 set line_number [expr $line_number+$comment_newlines]
1717 set comment [string trim $comment]
1718 set content [string range $content [expr $end+3] \
1719 [string length $content]]
1720 lappend mi_autotest_data [list $comment $comment_line]
1728 # Helper to mi_run_inline_test below.
1729 # Return the list of all (statement,line_number) lists
1730 # that comprise TESTCASE. The begin and end markers
1732 proc mi_get_inline_test {testcase} {
1734 global mi_gdb_prompt
1735 global mi_autotest_data
1736 global mi_autotest_source
1742 foreach l $mi_autotest_data {
1744 set comment [lindex $l 0]
1746 if {$comment == "BEGIN: $testcase"} {
1748 } elseif {$comment == "END: $testcase"} {
1751 } elseif {$seen_begin==1} {
1756 if {$seen_begin == 0} {
1757 error "Autotest $testcase not found"
1760 if {$seen_begin == 1 && $seen_end == 0} {
1761 error "Missing end marker for test $testcase"
1767 # Sets temporary breakpoint at LOCATION.
1768 proc mi_tbreak {location test} {
1770 global mi_gdb_prompt
1772 mi_gdb_test "-break-insert -t $location" \
1777 # Send COMMAND that must be a command that resumes
1778 # the inferior (run/continue/next/etc) and consumes
1779 # the "^running" output from it.
1780 proc mi_send_resuming_command_raw {command test} {
1782 global mi_gdb_prompt
1783 global thread_selected_re
1784 global library_loaded_re
1786 send_gdb "$command\n"
1788 -re "\\^running\r\n\\*running,thread-id=\"\[^\"\]+\"\r\n($library_loaded_re)*($thread_selected_re)?${mi_gdb_prompt}" {
1789 # Note that lack of 'pass' call here -- this works around limitation
1790 # in DejaGNU xfail mechanism. mi-until.exp has this:
1792 # setup_kfail gdb/2104 "*-*-*"
1795 # and mi_execute_to uses mi_send_resuming_command. If we use 'pass' here,
1796 # it will reset kfail, so when the actual test fails, it will be flagged
1800 -re "\\^error,msg=\"Displaced stepping is only supported in ARM mode\".*" {
1801 unsupported "$test (Thumb mode)"
1804 -re "\\^error,msg=.*" {
1805 fail "$test (MI error)"
1808 -re ".*${mi_gdb_prompt}" {
1809 fail "$test (failed to resume)"
1819 proc mi_send_resuming_command {command test} {
1820 mi_send_resuming_command_raw -$command $test
1823 # Helper to mi_run_inline_test below.
1824 # Sets a temporary breakpoint at LOCATION and runs
1825 # the program using COMMAND. When the program is stopped
1826 # returns the line at which it. Returns -1 if line cannot
1828 # Does not check that the line is the same as requested.
1829 # The caller can check itself if required.
1830 proc_with_prefix mi_continue_to_line {location test} {
1831 with_test_prefix $test {
1832 mi_tbreak $location "set temporary breakpoint"
1833 mi_send_resuming_command "exec-continue" "continue to breakpoint"
1834 return [mi_get_stop_line]
1838 # Wait until gdb prints the current line.
1839 proc mi_get_stop_line {} {
1841 global mi_gdb_prompt
1847 set prompt_re "$mi_gdb_prompt$"
1851 -re ".*line=\"(\[0-9\]*)\".*\r\n$prompt_re" {
1852 return $expect_out(1,string)
1854 -re ".*$mi_gdb_prompt" {
1855 fail "wait for stop (unexpected output)"
1858 fail "wait for stop (timeout)"
1863 # Run a MI test embedded in comments in a C file.
1864 # The C file should contain special comments in the following
1867 # /*: BEGIN: testname :*/
1868 # /*: <Tcl statements> :*/
1869 # /*: END: testname :*/
1871 # This procedure find the begin and end marker for the requested
1872 # test. Then, a temporary breakpoint is set at the begin
1873 # marker and the program is run (from start).
1875 # After that, for each special comment between the begin and end
1876 # marker, the Tcl statements are executed. It is assumed that
1877 # for each comment, the immediately preceding line is executable
1878 # C statement. Then, gdb will be single-stepped until that
1879 # preceding C statement is executed, and after that the
1880 # Tcl statements in the comment will be executed.
1884 # /*: BEGIN: assignment-test :*/
1886 # /*: <Tcl code to check that 'v' is indeed 10 :*/
1887 # /*: END: assignment-test :*/
1889 # The mi_prepare_inline_tests function should be called before
1890 # calling this function. A given C file can contain several
1891 # inline tests. The names of the tests must be unique within one
1894 proc mi_run_inline_test { testcase } {
1896 global mi_gdb_prompt
1899 global fullname_syntax
1900 global mi_autotest_source
1902 set commands [mi_get_inline_test $testcase]
1907 foreach c $commands {
1908 set statements [lindex $c 0]
1909 set line [lindex $c 1]
1910 set line [expr $line-1]
1912 # We want gdb to be stopped at the expression immediately
1913 # before the comment. If this is the first comment, the
1914 # program is either not started yet or is in some random place,
1915 # so we run it. For further comments, we might be already
1916 # standing at the right line. If not continue till the
1920 # Start the program afresh.
1921 mi_tbreak "$mi_autotest_source:$line" "set temporary breakpoint"
1922 if { [mi_run_cmd] < 0 } {
1925 set line_now [mi_get_stop_line]
1927 } elseif {$line_now!=$line} {
1928 set line_now [mi_continue_to_line "$mi_autotest_source:$line" "continue to $line"]
1931 if {$line_now!=$line} {
1932 fail "$testcase: go to line $line"
1935 # We're not at the statement right above the comment.
1936 # Execute that statement so that the comment can test
1937 # the state after the statement is executed.
1939 # Single-step past the line.
1940 if { [mi_send_resuming_command "exec-next" "$testcase: step over $line"] != 0 } {
1943 set line_now [mi_get_stop_line]
1945 # We probably want to use 'uplevel' so that statements
1946 # have direct access to global variables that the
1947 # main 'exp' file has set up. But it's not yet clear,
1948 # will need more experience to be sure.
1955 proc get_mi_thread_list {name} {
1958 # MI will return a list of thread ids:
1961 # ^done,thread-ids=[thread-id="1",thread-id="2",...],number-of-threads="N"
1963 mi_gdb_test "-thread-list-ids" \
1964 {.*\^done,thread-ids={(thread-id="[0-9]+"(,)?)+},current-thread-id="[0-9]+",number-of-threads="[0-9]+"} \
1965 "-thread_list_ids ($name)"
1968 if {[info exists expect_out(buffer)]} {
1969 set output $expect_out(buffer)
1973 if {![regexp {thread-ids=\{(thread-id="[0-9]+"(,)?)*\}} $output threads]} {
1974 fail "finding threads in MI output ($name)"
1976 pass "finding threads in MI output ($name)"
1978 # Make list of console threads
1979 set start [expr {[string first \{ $threads] + 1}]
1980 set end [expr {[string first \} $threads] - 1}]
1981 set threads [string range $threads $start $end]
1982 foreach thread [split $threads ,] {
1983 if {[scan $thread {thread-id="%d"} num]} {
1984 lappend thread_list $num
1992 # Check that MI and the console know of the same threads.
1993 # Appends NAME to all test names.
1994 proc check_mi_and_console_threads {name} {
1997 mi_gdb_test "-thread-list-ids" \
1998 {.*\^done,thread-ids={(thread-id="[0-9]+"(,)*)+},current-thread-id="[0-9]+",number-of-threads="[0-9]+"} \
1999 "-thread-list-ids ($name)"
2001 if {[info exists expect_out(buffer)]} {
2002 set mi_output $expect_out(buffer)
2005 # GDB will return a list of thread ids and some more info:
2008 # -interpreter-exec console "info threads"
2009 # ~" 4 Thread 2051 (LWP 7734) 0x401166b1 in __libc_nanosleep () at __libc_nanosleep:-1"
2010 # ~" 3 Thread 1026 (LWP 7733) () at __libc_nanosleep:-1"
2011 # ~" 2 Thread 2049 (LWP 7732) 0x401411f8 in __poll (fds=0x804bb24, nfds=1, timeout=2000) at ../sysdeps/unix/sysv/linux/poll.c:63"
2012 # ~"* 1 Thread 1024 (LWP 7731) main (argc=1, argv=0xbfffdd94) at ../../../src/gdb/testsuite/gdb.mi/pthreads.c:160"
2013 # FIXME: kseitz/2002-09-05: Don't use the hack-cli method.
2014 mi_gdb_test "info threads" \
2015 {.*(~".*"[\r\n]*)+.*} \
2016 "info threads ($name)"
2017 set console_output {}
2018 if {[info exists expect_out(buffer)]} {
2019 set console_output $expect_out(buffer)
2022 # Make a list of all known threads to console (gdb's thread IDs)
2023 set console_thread_list {}
2024 foreach line [split $console_output \n] {
2025 if {[string index $line 0] == "~"} {
2026 # This is a line from the console; trim off "~", " ", "*", and "\""
2027 set line [string trim $line ~\ \"\*]
2028 if {[scan $line "%d" id] == 1} {
2029 lappend console_thread_list $id
2034 # Now find the result string from MI
2036 foreach line [split $mi_output \n] {
2037 if {[string range $line 0 4] == "^done"} {
2041 if {$mi_result == ""} {
2042 fail "finding MI result string ($name)"
2044 pass "finding MI result string ($name)"
2047 # Finally, extract the thread ids and compare them to the console
2048 set num_mi_threads_str ""
2049 if {![regexp {number-of-threads="[0-9]+"} $mi_result num_mi_threads_str]} {
2050 fail "finding number of threads in MI output ($name)"
2052 pass "finding number of threads in MI output ($name)"
2054 # Extract the number of threads from the MI result
2055 if {![scan $num_mi_threads_str {number-of-threads="%d"} num_mi_threads]} {
2056 fail "got number of threads from MI ($name)"
2058 pass "got number of threads from MI ($name)"
2060 # Check if MI and console have same number of threads
2061 if {$num_mi_threads != [llength $console_thread_list]} {
2062 fail "console and MI have same number of threads ($name)"
2064 pass "console and MI have same number of threads ($name)"
2066 # Get MI thread list
2067 set mi_thread_list [get_mi_thread_list $name]
2069 # Check if MI and console have the same threads
2071 foreach ct [lsort $console_thread_list] mt [lsort $mi_thread_list] {
2077 fail "MI and console have same threads ($name)"
2079 # Send a list of failures to the log
2080 send_log "Console has thread ids: $console_thread_list\n"
2081 send_log "MI has thread ids: $mi_thread_list\n"
2083 pass "MI and console have same threads ($name)"
2090 # Set solib-search-path to allow gdb to locate shlib FILE.
2091 proc mi_locate_shlib { file } {
2094 if ![info exists mi_spawn_id] {
2095 perror "mi_locate_shlib: GDB is not running"
2098 # If the target is remote, we need to tell gdb where to find the
2100 if { ![is_remote target] } {
2104 # We could set this even when not testing remotely, but a user
2105 # generally won't set it unless necessary. In order to make the tests
2106 # more like the real-life scenarios, we don't set it for local testing.
2107 mi_gdb_test "set solib-search-path [file dirname $file]" "\^done" ""
2110 # Copy shlib FILE to the target and set solib-search-path to allow gdb to
2112 proc mi_load_shlib { file } {
2113 set dest [gdb_download_shlib $file]
2114 mi_locate_shlib $file
2118 # Download shared libraries to the target.
2119 proc mi_load_shlibs { args } {
2120 foreach file $args {
2125 proc mi_check_thread_states { states test } {
2127 set pattern ".*\\^done,threads=\\\["
2129 set pattern "${pattern}(.*)state=\"$s\""
2131 set pattern "${pattern}(,core=\"\[0-9\]*\")?\\\}\\\].*"
2133 verbose -log "expecting: $pattern"
2134 mi_gdb_test "-thread-info" $pattern $test
2137 # Return a list of MI features supported by this gdb.
2138 proc mi_get_features {} {
2139 global expect_out mi_gdb_prompt
2141 send_gdb "-list-features\n"
2144 -re "\\^done,features=\\\[(.*)\\\]\r\n$mi_gdb_prompt$" {
2145 regsub -all -- \" $expect_out(1,string) "" features
2146 return [split $features ,]
2148 -re ".*\r\n$mi_gdb_prompt$" {
2149 verbose -log "got $expect_out(buffer)"
2153 verbose -log "timeout in mi_gdb_prompt"
2159 # Variable Object Trees
2161 # Yet another way to check varobjs. Pass mi_walk_varobj_tree a "list" of
2162 # variables (not unlike the actual source code definition), and it will
2163 # automagically test the children for you (by default).
2185 # foo *f = new foo (); <-- break here
2187 # We want to check all the children of "f".
2189 # Translate the above structures into the following tree:
2195 # anonymous struct {
2206 # {const int *} iPtr {
2207 # {const int} {*iPtr} {}
2217 # mi_walk_varobj_tree c++ $tree
2219 # If you'd prefer to walk the tree using your own callback,
2220 # simply pass the name of the callback to mi_walk_varobj_tree.
2222 # This callback should take one argument, the name of the variable
2223 # to process. This name is the name of a global array holding the
2224 # variable's properties (object name, type, etc).
2226 # An example callback:
2228 # proc my_callback {var} {
2229 # upvar #0 $var varobj
2231 # puts "my_callback: called on varobj $varobj(obj_name)"
2234 # The arrays created for each variable object contain the following
2237 # obj_name - the object name for accessing this variable via MI
2238 # display_name - the display name for this variable (exp="display_name" in
2239 # the output of -var-list-children)
2240 # type - the type of this variable (type="type" in the output
2241 # of -var-list-children, or the special tag "anonymous"
2242 # path_expr - the "-var-info-path-expression" for this variable
2243 # NOTE: This member cannot be used reliably with typedefs.
2245 # See notes inside get_path_expr for more.
2246 # parent - the variable name of the parent varobj
2247 # children - a list of children variable names (which are the
2248 # names Tcl arrays, not object names)
2250 # For each variable object, an array containing the above fields will
2251 # be created under the root node (conveniently called, "root"). For example,
2252 # a variable object with handle "OBJ.public.0_anonymous.a" will have
2253 # a corresponding global Tcl variable named "root.OBJ.public.0_anonymous.a".
2255 # Note that right now, this mechanism cannot be used for recursive data
2256 # structures like linked lists.
2258 namespace eval ::varobj_tree {
2259 # An index which is appended to root varobjs to ensure uniqueness.
2260 variable _root_idx 0
2262 # A procedure to help with debuggging varobj trees.
2263 # VARIABLE_NAME is the name of the variable to dump.
2264 # CMD, if present, is the name of the callback to output the contstructed
2265 # strings. By default, it uses expect's "send_log" command.
2266 # TERM, if present, is a terminating character. By default it is the newline.
2268 # To output to the terminal (not the expect log), use
2269 # mi_varobj_tree_dump_variable my_variable puts ""
2271 proc mi_varobj_tree_dump_variable {variable_name {cmd send_log} {term "\n"}} {
2272 upvar #0 $variable_name varobj
2274 eval "$cmd \"VAR = $variable_name$term\""
2276 # Explicitly encode the array indices, since outputting them
2277 # in some logical order is better than what "array names" might
2279 foreach idx {obj_name parent display_name type path_expr} {
2280 eval "$cmd \"\t$idx = $varobj($idx)$term\""
2284 set num [llength $varobj(children)]
2285 eval "$cmd \"\tnum_children = $num$term\""
2287 eval "$cmd \"\tchildren = $varobj(children)$term\""
2291 # The default callback used by mi_walk_varobj_tree. This callback
2292 # simply checks all of VAR's children. It specifically does not test
2293 # path expressions, since that is very problematic.
2295 # This procedure may be used in custom callbacks.
2296 proc test_children_callback {variable_name} {
2297 upvar #0 $variable_name varobj
2299 if {[llength $varobj(children)] > 0} {
2300 # Construct the list of children the way mi_list_varobj_children
2301 # expects to get it:
2302 # { {obj_name display_name num_children type} ... }
2303 set children_list {}
2304 foreach child $varobj(children) {
2306 set clist [list [string_to_regexp $c(obj_name)] \
2307 [string_to_regexp $c(display_name)] \
2308 [llength $c(children)]]
2309 if {[string length $c(type)] > 0} {
2310 lappend clist [string_to_regexp $c(type)]
2312 lappend children_list $clist
2315 mi_list_varobj_children $varobj(obj_name) $children_list \
2316 "VT: list children of $varobj(obj_name)"
2320 # Set the properties of the varobj represented by
2321 # PARENT_VARIABLE - the name of the parent's variable
2322 # OBJNAME - the MI object name of this variable
2323 # DISP_NAME - the display name of this variable
2324 # TYPE - the type of this variable
2325 # PATH - the path expression for this variable
2326 # CHILDREN - a list of the variable's children
2327 proc create_varobj {parent_variable objname disp_name \
2328 type path children} {
2329 upvar #0 $parent_variable parent
2331 set var_name "root.$objname"
2333 array set $var_name [list obj_name $objname]
2334 array set $var_name [list display_name $disp_name]
2335 array set $var_name [list type $type]
2336 array set $var_name [list path_expr $path]
2337 array set $var_name [list parent "$parent_variable"]
2338 array set $var_name [list children \
2339 [get_tree_children $var_name $children]]
2343 # Should VARIABLE be used in path expressions? The CPLUS_FAKE_CHILD
2344 # varobjs and anonymous structs/unions are not used for path expressions.
2345 proc is_path_expr_parent {variable} {
2346 upvar #0 $variable varobj
2348 # If the varobj's type is "", it is a CPLUS_FAKE_CHILD.
2349 # If the tail of the varobj's object name is "%d_anonymous",
2350 # then it represents an anonymous struct or union.
2351 if {[string length $varobj(type)] == 0 \
2352 || [regexp {[0-9]+_anonymous$} $varobj(obj_name)]} {
2359 # Return the path expression for the variable named NAME in
2360 # parent varobj whose variable name is given by PARENT_VARIABLE.
2361 proc get_path_expr {parent_variable name type} {
2362 upvar #0 $parent_variable parent
2363 upvar #0 $parent_variable path_parent
2365 # If TYPE is "", this is one of the CPLUS_FAKE_CHILD varobjs,
2366 # which has no path expression. Likewsise for anonymous structs
2368 if {[string length $type] == 0 \
2369 || [string compare $type "anonymous"] == 0} {
2373 # Find the path parent variable.
2374 while {![is_path_expr_parent $parent_variable]} {
2375 set parent_variable $path_parent(parent)
2376 upvar #0 $parent_variable path_parent
2379 # This is where things get difficult. We do not actually know
2380 # the real type for variables defined via typedefs, so we don't actually
2381 # know whether the parent is a structure/union or not.
2383 # So we assume everything that isn't a simple type is a compound type.
2385 regexp {\*+} $parent(type) stars
2387 if {[string index $name 0] == "*"} {
2391 if {[string index $parent(type) end] == "\]"} {
2392 # Parent is an array.
2393 return "($path_parent(path_expr))\[$name\]"
2394 } elseif {$is_compound} {
2395 # Parent is a structure or union or a pointer to one.
2396 if {[string length $stars]} {
2404 # To make matters even more hideous, varobj.c has slightly different
2405 # path expressions for C and C++.
2406 set path_expr "($path_parent(path_expr))$join$name"
2407 if {[string compare -nocase $root(language) "c"] == 0} {
2410 return "($path_expr)"
2413 # Parent is a pointer.
2414 return "*($path_parent(path_expr))"
2418 # Process the CHILDREN (a list of varobj_tree elements) of the variable
2419 # given by PARENT_VARIABLE. Returns a list of children variables.
2420 proc get_tree_children {parent_variable children} {
2421 upvar #0 $parent_variable parent
2424 set children_list {}
2425 foreach {type name children} $children {
2426 if {[string compare $parent_variable "root"] == 0} {
2430 set objname "$name$_root_idx"
2431 set disp_name "$name"
2432 set path_expr "$name"
2433 } elseif {[string compare $type "anonymous"] == 0} {
2434 # Special case: anonymous types. In this case, NAME will either be
2435 # "struct" or "union".
2436 set objname "$parent(obj_name).${field_idx}_anonymous"
2437 set disp_name "<anonymous $name>"
2439 set type "$name {...}"
2441 set objname "$parent(obj_name).$name"
2443 set path_expr [get_path_expr $parent_variable $name $type]
2446 lappend children_list [create_varobj $parent_variable $objname \
2447 $disp_name $type $path_expr $children]
2451 return $children_list
2454 # The main procedure to call the given CALLBACK on the elements of the
2455 # given varobj TREE. See detailed explanation above.
2456 proc walk_tree {language tree callback} {
2460 if {[llength $tree] < 3} {
2461 error "tree does not contain enough elements"
2466 # Create root node and process the tree.
2467 array set root [list language $language]
2468 array set root [list obj_name "root"]
2469 array set root [list display_name "root"]
2470 array set root [list type "root"]
2471 array set root [list path_expr "root"]
2472 array set root [list parent "root"]
2473 array set root [list children [get_tree_children root $tree]]
2476 set all_nodes $root(children); # a stack of nodes
2477 while {[llength $all_nodes] > 0} {
2478 # "Pop" the name of the global variable containing this varobj's
2479 # information from the stack of nodes.
2480 set var_name [lindex $all_nodes 0]
2481 set all_nodes [lreplace $all_nodes 0 0]
2483 # Bring the global named in VAR_NAME into scope as the local variable
2485 upvar #0 $var_name varobj
2487 # Append any children of VAROBJ to the list of nodes to walk.
2488 if {[llength $varobj(children)] > 0} {
2489 set all_nodes [concat $all_nodes $varobj(children)]
2492 # If this is a root variable, create the variable object for it.
2493 if {[string compare $varobj(parent) "root"] == 0} {
2494 mi_create_varobj $varobj(obj_name) $varobj(display_name) \
2495 "VT: create root varobj for $varobj(display_name)"
2498 # Now call the callback for VAROBJ.
2499 uplevel #0 $callback $var_name
2504 # The default varobj tree callback, which simply tests -var-list-children.
2505 proc mi_varobj_tree_test_children_callback {variable} {
2506 ::varobj_tree::test_children_callback $variable
2509 # Walk the variable object tree given by TREE, calling the specified
2510 # CALLBACK. By default this uses mi_varobj_tree_test_children_callback.
2511 proc mi_walk_varobj_tree {language tree \
2513 mi_varobj_tree_test_children_callback}} {
2514 ::varobj_tree::walk_tree $language $tree $callback
2517 # Build a list of key-value pairs given by the list ATTR_LIST. Flatten
2518 # this list using the optional JOINER, a comma by default.
2520 # The list must contain an even number of elements, which are the key-value
2521 # pairs. Each value will be surrounded by quotes, according to the grammar,
2522 # except if the value starts with \[ or \{, when the quotes will be omitted.
2524 # Example: mi_build_kv_pairs {a b c d e f g \[.*\]}
2525 # returns a=\"b\",c=\"d\",e=\"f\",g=\[.*\]
2526 proc mi_build_kv_pairs {attr_list {joiner ,}} {
2528 foreach {var value} $attr_list {
2529 if {[string range $value 0 1] == "\\\["
2530 || [string range $value 0 1] == "\\\{"} {
2531 lappend l "$var=$value"
2533 lappend l "$var=\"$value\""
2536 return "[join $l $joiner]"
2539 # Construct a breakpoint location regexp. This may be used along with
2540 # mi_make_breakpoint_multi to test the output of -break-insert,
2541 # -dprintf-insert, or -break-info with breapoints with multiple
2544 # All arguments for the breakpoint location may be specified using the
2545 # options: number, enabled, addr, func, file, fullname, line, inferior
2546 # thread-groups, and thread.
2548 # For the option -thread the corresponding output field is only added
2549 # if the option is present and not set to the empty string.
2551 # Example: mi_make_breakpoint_loc -number 2.1 -file ".*/myfile.c" -line 3
2552 # will return the breakpoint location:
2553 # {number="2.1",enabled=".*",addr=".*",func=".*",
2554 # file=".*/myfile.c",fullname=".*",line="3",thread-groups=\[.*\]}
2556 proc mi_make_breakpoint_loc {args} {
2557 parse_args {{number .*} {enabled .*} {addr .*}
2558 {func .*} {file .*} {fullname .*} {line .*}
2559 {thread-groups \\\[.*\\\]} {thread ""} {inferior ""}}
2562 foreach attr [list number enabled addr func file \
2563 fullname line thread-groups inferior] {
2564 if {$attr ne "inferior" || [set $attr] ne ""} {
2565 lappend attr_list $attr [set $attr]
2569 set result [mi_build_kv_pairs $attr_list]
2571 if {[string length $thread] > 0} {
2573 append result [mi_build_kv_pairs [list "thread" $thread]]
2579 # Bits shared between mi_make_breakpoint and mi_make_breakpoint_multi.
2581 proc mi_make_breakpoint_1 {attr_list thread inferior cond evaluated-by \
2582 times ignore script original-location} {
2583 set result "bkpt=\\\{[mi_build_kv_pairs $attr_list]"
2585 # There are always exceptions.
2587 # If THREAD is not present, do not output it.
2588 if {[string length $thread] > 0} {
2590 append result [mi_build_kv_pairs [list "thread" $thread]]
2593 # If INFERIOR is not present, do not output it.
2594 if {[string length $inferior] > 0} {
2596 append result [mi_build_kv_pairs [list "inferior" $inferior]]
2599 # If COND is not present, do not output it.
2600 if {[string length $cond] > 0} {
2602 append result [mi_build_kv_pairs [list "cond" $cond]]
2604 # When running on a remote, GDB may output who is evaluating
2605 # breakpoint conditions.
2606 if {[string length ${evaluated-by}] > 0} {
2607 append result [mi_build_kv_pairs \
2608 [list "evaluated-by" ${evaluated-by}]]
2610 append result {(,evaluated-by=".*")?}
2615 append result [mi_build_kv_pairs [list "times" $times]]
2617 # If SCRIPT and IGNORE are not present, do not output them.
2620 append result [mi_build_kv_pairs [list "ignore" $ignore]]
2623 if {[string length $script] > 0} {
2625 append result [mi_build_kv_pairs [list "script" $script]]
2628 # Allow anything up until the next "official"/required attribute.
2629 # This pattern skips over script/ignore if matches on those
2630 # were not specifically required by the caller.
2633 append result [mi_build_kv_pairs \
2634 [list "original-location" ${original-location}]]
2639 # Construct a regexp to match against a frame description as returned by
2640 # -stack-info-frame. Take a list of name value pairs. Valid names are
2641 # -level, -addr, -func, -file, -fullname, line, and -arch, each takes a
2642 # regexp which is matched against the corresponding field in the
2643 # -stack-info-frame output.
2645 proc mi_make_info_frame_regexp {args} {
2646 parse_args [list [list level "$::decimal"] [list addr "$::hex"] \
2647 {func .*} {file .*} {fullname .*} \
2648 [list line "$::decimal"] {arch .*}]
2651 foreach attr {level addr func file fullname line arch} {
2652 lappend attr_list $attr [set $attr]
2655 set result "frame=\\\{"
2656 append result [mi_build_kv_pairs $attr_list]
2657 append result "\\\}"
2661 # Run the -stack-info-frame command and match the result, return true if the
2662 # test passes, otherwise, return false.
2664 # TEST is the name used for this test.
2666 # ARGS is an optional list of name value pairs, the names -frame and -thread
2667 # if present, expect a decimal argument and control the frame and thread for
2668 # which -stack-info-frame is run. If -frame is not given then the
2669 # -stack-info-frame will operate on the current frame. If -thread is not
2670 # given then -stack-info-frame will operate on the current thread.
2672 # The remaining arguments are passed to mi_make_frame_regexp and are used to
2673 # build the regexp for matching against the -stack-info-frame output.
2675 proc mi_info_frame { test args } {
2676 parse_args {{frame ""} {thread ""}}
2678 set re [eval mi_make_info_frame_regexp $args]
2680 set cmd "235-stack-info-frame"
2682 append cmd " --frame ${frame}"
2684 if {$thread ne ""} {
2685 append cmd " --thread ${thread}"
2688 return [mi_gdb_test $cmd "235\\^done,$re" $test]
2691 # Construct a breakpoint regexp, for a breakpoint with multiple
2692 # locations. This may be used to test the output of -break-insert,
2693 # -dprintf-insert, or -break-info with breakpoints with multiple
2696 # All arguments for the breakpoint may be specified using the options:
2697 # number, type, disp, enabled, times, ignore, script, inferior,
2698 # original-location, cond, evaluated-by, locations, and thread.
2700 # Only if -script and -ignore are given will they appear in the output.
2701 # Otherwise, this procedure will skip them using ".*".
2703 # For the options -thread and -cond the corresponding output fields
2704 # are only added if the options are present and not set to the empty
2707 # Example: mi_make_breakpoint_multi -number 2 -locations "$loc"
2708 # will return the breakpoint:
2709 # bkpt={number="2",type=".*",disp=".*",enabled=".*",addr="<MULTIPLE>",
2710 # times="0".*original-location=".*",locations=$loc}
2712 # You can construct the list of locations with mi_make_breakpoint_loc.
2714 proc mi_make_breakpoint_multi {args} {
2715 parse_args {{number .*} {type .*} {disp .*} {enabled .*}
2716 {times .*} {ignore 0}
2717 {script ""} {original-location .*} {cond ""} {evaluated-by ""}
2718 {locations .*} {thread ""} {inferior ""}}
2721 foreach attr [list number type disp enabled] {
2722 lappend attr_list $attr [set $attr]
2725 lappend attr_list "addr" "<MULTIPLE>"
2727 set result [mi_make_breakpoint_1 \
2728 $attr_list $thread $inferior $cond ${evaluated-by} \
2729 $times $ignore $script ${original-location}]
2732 append result [mi_build_kv_pairs [list "locations" $locations]]
2734 append result "\\\}"
2738 # Construct a breakpoint regexp, for a pending breakpoint. This may
2739 # be used to test the output of -break-insert, -dprintf-insert, or
2740 # -break-info for pending breakpoints.
2742 # Arguments for the breakpoint may be specified using the options:
2743 # number, type, disp, enabled, pending, original-location, thread, and
2746 # For the options -thread and -cond the corresponding output fields
2747 # are only included if the options are present and not the empty
2750 # Example: mi_make_breakpoint_pending -number 2 -pending func
2751 # will return the breakpoint:
2752 # bkpt={number="2",type=".*",disp=".*",enabled=".*",addr="<PENDING>",
2753 # pending="func", times="0".*original-location=".*"}
2755 proc mi_make_breakpoint_pending {args} {
2756 parse_args {{number .*} {type .*} {disp .*} {enabled .*}
2757 {pending .*} {original-location .*} {thread ""} {inferior ""}
2758 {cond ""} {script ""} {times .*}}
2761 foreach attr [list number type disp enabled] {
2762 lappend attr_list $attr [set $attr]
2765 lappend attr_list "addr" "<PENDING>"
2767 foreach attr [list pending] {
2768 lappend attr_list $attr [set $attr]
2774 set result [mi_make_breakpoint_1 \
2775 $attr_list $thread $inferior $cond ${evaluated-by} \
2776 $times $ignore $script ${original-location}]
2778 append result "\\\}"
2782 # Construct a breakpoint regexp. This may be used to test the output of
2783 # -break-insert, -dprintf-insert, or -break-info.
2785 # All arguments for the breakpoint may be specified using the options
2786 # number, type, disp, enabled, addr, func, file, fullanme, line,
2787 # thread-groups, cond, evaluated-by, times, ignore, script,
2788 # and original-location.
2790 # Only if -script and -ignore are given will they appear in the output.
2791 # Otherwise, this procedure will skip them using ".*".
2793 # Example: mi_make_breakpoint -number 2 -file ".*/myfile.c" -line 3
2794 # will return the breakpoint:
2795 # bkpt={number="2",type=".*",disp=".*",enabled=".*",addr=".*",func=".*",
2796 # file=".*/myfile.c",fullname=".*",line="3",thread-groups=\[.*\],
2797 # times="0".*original-location=".*"}
2799 proc mi_make_breakpoint {args} {
2800 parse_args {{number .*} {type .*} {disp .*} {enabled .*} {addr .*}
2801 {func .*} {file .*} {fullname .*} {line .*}
2802 {thread-groups \\\[.*\\\]} {times .*} {ignore 0}
2803 {script ""} {original-location .*} {cond ""} {evaluated-by ""}
2804 {thread ""} {inferior ""}}
2807 foreach attr [list number type disp enabled addr func file \
2808 fullname line thread-groups] {
2809 lappend attr_list $attr [set $attr]
2812 set result [mi_make_breakpoint_1 \
2813 $attr_list $thread $inferior $cond ${evaluated-by} \
2814 $times $ignore $script ${original-location}]
2816 append result "\\\}"
2820 # Build a breakpoint table regexp given the list of breakpoints in `bp_list',
2821 # constructed by mi_make_breakpoint.
2823 # Example: Construct a breakpoint table where the only attributes we
2824 # test for are the existence of three breakpoints numbered 1, 2, and 3.
2827 # lappend bps [mi_make_breakpoint -number 1]
2828 # lappend bps [mi_make_breakpoint -number 2]
2829 # lappned bps [mi_make_breakpoint -number 3]
2830 # mi_make_breakpoint_table $bps
2831 # will return (abbreviated for clarity):
2832 # BreakpointTable={nr_rows="3",nr_cols="6",hdr=[{width=".*",...} ...],
2833 # body=[bkpt={number="1",...},bkpt={number="2",...},bkpt={number="3",...}]}
2835 proc mi_make_breakpoint_table {bp_list} {
2836 # Build header -- assume a standard header for all breakpoint tables.
2838 foreach {nm hdr} [list number Num type Type disp Disp enabled Enb \
2839 addr Address what What] {
2840 # The elements here are the MI table headers, which have the
2842 # {width="7",alignment="-1",col_name="number",colhdr="Num"}
2843 lappend hl "{[mi_build_kv_pairs [list width .* alignment .* \
2844 col_name $nm colhdr $hdr]]}"
2846 set header "hdr=\\\[[join $hl ,]\\\]"
2848 # The caller has implicitly supplied the number of columns and rows.
2849 set nc [llength $hl]
2850 set nr [llength $bp_list]
2852 # Build body -- mi_make_breakpoint has done most of the work.
2853 set body "body=\\\[[join $bp_list ,]\\\]"
2855 # Assemble the final regexp.
2856 return "BreakpointTable={nr_rows=\"$nr\",nr_cols=\"$nc\",$header,$body}"
2859 # As skip_libstdcxx_probe_tests_prompt, with mi_gdb_prompt.
2861 proc mi_skip_libstdcxx_probe_tests {} {
2862 global mi_gdb_prompt
2863 return [skip_libstdcxx_probe_tests_prompt "$mi_gdb_prompt$"]
2866 # Retrieve the value of EXP in the inferior, represented in format
2867 # specified in FMT (using "printFMT"). DEFAULT is used as fallback if
2868 # print fails. TEST is the test message to use. It can be omitted,
2869 # in which case a test message is built from EXP.
2871 # This is an MI version of gdb_valueof.
2873 proc mi_get_valueof { fmt exp default {test ""} } {
2874 global mi_gdb_prompt
2877 set test "get valueof \"${exp}\""
2881 gdb_test_multiple "print${fmt} ${exp}" "$test" -prompt "$::mi_gdb_prompt$" {
2882 -re "~\"\\$\[0-9\]* = (\[^\r\n\]*)\\\\n\"\r\n\\^done\r\n$mi_gdb_prompt$" {
2883 set val $expect_out(1,string)
2887 fail "$test (timeout)"
2893 # Some MI tests should be run in the normal way, on the main UI, while
2894 # other tests should be run twice, once when the MI is on the main UI,
2895 # and once with the MI on a secondary UI, this proc facilitates that.
2899 # foreach_mi_ui_mode mode {
2903 # The BODY will then be run once with MODE set to 'main' and once with
2904 # MODE set to 'separate'.
2906 # However, there are times when we know using the 'separate' UI will
2907 # not work. This proc handles figuring that out, if the 'separate' UI
2908 # is known not to work then the 'separate' mode will be skipped and
2909 # BODY will be run just once with MODE set to 'main'.
2911 proc foreach_mi_ui_mode { var_name body } {
2912 upvar 1 $var_name var
2914 if [gdb_debug_enabled] {
2915 # gdb debug doesn't work for separate-mi-tty.
2918 set modes {"main" "separate"}
2921 foreach var $modes {
2922 with_test_prefix "$var_name=$var" {
2923 set code [catch {uplevel 1 $body} result]
2927 global errorInfo errorCode
2928 return -code $code -errorinfo $errorInfo -errorcode $errorCode $result
2929 } elseif {$code == 3} {
2931 } elseif {$code == 2} {
2932 return -code $code $result
2937 # Check if GDB has information about the stderr symbol.
2938 proc mi_gdb_is_stderr_available {} {
2939 set has_stderr_symbol false
2941 set cmd "-data-evaluate-expression stderr"
2942 set test "stderr symbol check"
2943 set msg_re {"'stderr' has unknown type; cast it to its declared type"}
2944 gdb_test_multiple $cmd $test -prompt "$::mi_gdb_prompt$" {
2945 -re -wrap "\\^error,msg=$msg_re" {
2946 # Default value of false is fine.
2949 set has_stderr_symbol true
2953 return $has_stderr_symbol