Re: RFC: gdb_test_multiple

Re: RFC: gdb_test_multiple

[Michael Elizabeth Chastain]

Hi Daniel,

> This isn't a style thing, though.  Let me point out the actual
> syntactic difference between the two above: the strings are
> expanded/substituted at the time of the call to gdb_test_multiple
> instead of at the time of the actual expect {}, down the call chain.

I don't understand.  Are you saying that:

  set msg "breakpoint on Foo::Bar"
  gdb_test_multiple "break Foo::Bar" $msg {
    -re "foo" {
      ... fail $msg ...
    }
  }

requires something gross in gdb_test_multiple in order to work?

I guess my question is: when does the "$msg" in "fail $msg" get
expanded.  If the caller expands it before calling gdb_test_multiple
then I don't see the problem.  If the caller passes "{ ... fail $msg ... }"
without expanding $msg then I do see the problem.

Michael C

Re: RFC: gdb_test_multiple

[Daniel Jacobowitz]

On Sun, Jan 05, 2003 at 10:53:57AM -0600, Michael Elizabeth Chastain wrote:
> Hi Daniel,
> 
> > This isn't a style thing, though.  Let me point out the actual
> > syntactic difference between the two above: the strings are
> > expanded/substituted at the time of the call to gdb_test_multiple
> > instead of at the time of the actual expect {}, down the call chain.
> 
> I don't understand.  Are you saying that:
> 
>   set msg "breakpoint on Foo::Bar"
>   gdb_test_multiple "break Foo::Bar" $msg {
>     -re "foo" {
>       ... fail $msg ...
>     }
>   }
> 
> requires something gross in gdb_test_multiple in order to work?

No, but this similar construct:

   set teststr "foo"
   gdb_test_multiple "break Foo::Bar" $msg {
     -re "$teststr" {
       ... fail $msg ...
     }
   }

does.  And that idiom is all over the testsuite, for readability
purposes; see $hex, etc.

> I guess my question is: when does the "$msg" in "fail $msg" get
> expanded.  If the caller expands it before calling gdb_test_multiple
> then I don't see the problem.  If the caller passes "{ ... fail $msg ... }"
> without expanding $msg then I do see the problem.

{ } quoting in TCL completely disables expansion.  Variables inside a
"proc name { args } { vars $here } are not expanded until the procedure
is called; similarly for the {} construct above.

If you think about it, this is logical.  Consider
$expect_out(0,string), which is based on the regular expression match.
Its value isn't known when gdb_test_multiple is called, so it can't be
expanded until after the matching is done.

-- 
Daniel Jacobowitz
MontaVista Software                         Debian GNU/Linux Developer

Re: RFC: gdb_test_multiple

[Michael Elizabeth Chastain]

I did a test spin and it came out with no significant problems,
just one irritating glitch that I haven't tracked down.

I tested with:

  #1 stock dejagnu
  #2 stock dejagnu + gdb_test_multiple
  #3 sourceware dejagnu + gdb_test_multiple

"stock dejagnu" means tcl, expect, and dejagnu built from their primary
ftp sites.

"sourceware dejagnu" means tcl, expect, and dejagnu from the
sources.redhat.com cvs repository, module dejagnu

#1 versus #2 came out perfectly.
#2 versus #3 came out with a difference in gdb.threads/pthreads.exp
(#2 is consisently good, #3 has intermittent failures).  Chances
are about 0.5% that it's an issue with the gdb_test_multiple patch.

I blew it and did not do a spin with "sourceware dejagnu" before
applying the patch and I've applied other stuff to my test bed
since then.

> OK.  I'll have an even easier version of this done tomorrow; it has one
> truely gruesome TCL hack in it, but that's it.

I'd like to do another test spin on the new version before you commit
it if that's all right with you.  I can do a cut-down version but I'd
like to be really sure about sourceware dejagnu because the damn things
are subtly different, and I normally don't test with it.

Michael C

Re: RFC: gdb_test_multiple

[Daniel Jacobowitz]

On Mon, Jan 06, 2003 at 04:12:34PM -0500, Andrew Cagney wrote:
> >I want to think about this a little more anyway; as Michael mentioned,
> >I don't think it's recursion safe.  I can't fix this syntax due to TCL
> >limitations, so it might become:
> >
> >gdb_test_multiple "break Foo::Bar" "breakpoint on Foo::Bar" \
> >  "Breakpoint at .*\[\r\n\]$gdb_prompt $" { pass $msg } \
> >  "Bang." { kfail "gdb/90211" $msg }
> >
> >Which isn't so bad, after all.  I had some reason not to do it that way
> >but I can't remember what it was, now.  What do you think of this
> >change?
> 
> Which ever.  My concern is with `$_gdb_message'.  Knowing how to use 
> that would have required a deep understanding of what the function 
> gdb_test_multiple{} was doing.  The above at least makes immediate sense 
> to someone with little tcl/tk knowledge (read: average gdb developer :-).

OK.  I'll have an even easier version of this done tomorrow; it has one
truely gruesome TCL hack in it, but that's it.

-- 
Daniel Jacobowitz
MontaVista Software                         Debian GNU/Linux Developer

Re: RFC: gdb_test_multiple

[Andrew Cagney]

> I want to think about this a little more anyway; as Michael mentioned,
> I don't think it's recursion safe.  I can't fix this syntax due to TCL
> limitations, so it might become:
> 
> gdb_test_multiple "break Foo::Bar" "breakpoint on Foo::Bar" \
>   "Breakpoint at .*\[\r\n\]$gdb_prompt $" { pass $msg } \
>   "Bang." { kfail "gdb/90211" $msg }
> 
> Which isn't so bad, after all.  I had some reason not to do it that way
> but I can't remember what it was, now.  What do you think of this
> change?

Which ever.  My concern is with `$_gdb_message'.  Knowing how to use 
that would have required a deep understanding of what the function 
gdb_test_multiple{} was doing.  The above at least makes immediate sense 
to someone with little tcl/tk knowledge (read: average gdb developer :-).

Andrew

Re: RFC: gdb_test_multiple

[Michael Elizabeth Chastain]

> { } quoting in TCL completely disables expansion.  Variables inside a
> "proc name { args } { vars $here } are not expanded until the procedure
> is called; similarly for the {} construct above.

Ah.  Gotcha.  I am thinking like #define, when I really need to think
like gnu make's "=" and ":=" (and sit down with the TCL book and really
learn the silly language).

> And that idiom is all over the testsuite, for readability
> purposes; see $hex, etc.

In fact I'm planning to use more of that idiom to incrementally build
up -re strings that for those troublesome ptype tests.

So I have to acquiesce to you -- whatever syntax you can get to work.

Michael C

Re: RFC: gdb_test_multiple

[Daniel Jacobowitz]

On Sun, Jan 05, 2003 at 10:33:02AM -0600, Michael Elizabeth Chastain wrote:
> Daniel Jacobowitz writes:
> 
>   set msg "breakpoint on Foo::Bar"
>   gdb_test_multiple "break Foo::Bar" "breakpoint on Foo::Bar" {
>   ... fail "$msg ...
>   }
> 
> This can be improved to:
> 
>   set msg "breakpoint on Foo::Bar"
>   gdb_test_multiple "break Foo::Bar" $msg {
>   ... fail $msg ...
>   }
> 
> The grammar would still allow different messages for the explicit
> messages given by the caller versus the internal messages generated
> by gdb_test_multiple.  But the normal idiom would have one $msg.
> 
>   gdb_test_multiple "break Foo::Bar" "breakpoint on Foo::Bar" \
>     "Breakpoint at .*\[\r\n\]$gdb_prompt $" { pass $msg } \
>     "Bang." { kfail "gdb/90211" $msg }
> 
> Err, I like my treatment of $msg better, I dislike subroutines that
> create variables like this for little inferior blocks of code.
> But maybe I have poor taste in TCL style.

This isn't a style thing, though.  Let me point out the actual
syntactic difference between the two above: the strings are
expanded/substituted at the time of the call to gdb_test_multiple
instead of at the time of the actual expect {}, down the call chain.

This means that I don't have to do the grossness with populating
variables in the caller's namespace, which violates every bit of
stylistic sense I've got left after yesterday.

Could even arrange to run the { pass $foo } block in the caller's
level, which is exactly as expected.

I like the revised proposal much more :)  What do you think of it?

-- 
Daniel Jacobowitz
MontaVista Software                         Debian GNU/Linux Developer

Re: RFC: gdb_test_multiple

[Michael Elizabeth Chastain]

Daniel Jacobowitz writes:

  set msg "breakpoint on Foo::Bar"
  gdb_test_multiple "break Foo::Bar" "breakpoint on Foo::Bar" {
  ... fail "$msg ...
  }

This can be improved to:

  set msg "breakpoint on Foo::Bar"
  gdb_test_multiple "break Foo::Bar" $msg {
  ... fail $msg ...
  }

The grammar would still allow different messages for the explicit
messages given by the caller versus the internal messages generated
by gdb_test_multiple.  But the normal idiom would have one $msg.

  gdb_test_multiple "break Foo::Bar" "breakpoint on Foo::Bar" \
    "Breakpoint at .*\[\r\n\]$gdb_prompt $" { pass $msg } \
    "Bang." { kfail "gdb/90211" $msg }

Err, I like my treatment of $msg better, I dislike subroutines that
create variables like this for little inferior blocks of code.
But maybe I have poor taste in TCL style.

Michael C

Re: RFC: gdb_test_multiple

[Daniel Jacobowitz]

On Sun, Jan 05, 2003 at 10:32:45AM -0500, Andrew Cagney wrote:
> >gdb_test_multiple "break Foo::Bar" "breakpoint on Foo::Bar" {
> >  -re "Breakpoint at .*\[\r\n\]$gdb_prompt $" {
> >    pass "$_gdb_message"
> >  }
> >  -re "Explode!" {
> >    fail "$_gdb_message (gdb/90210)"
> >  }
> >  -re "Bang." {
> >    kfail "gdb/90211" "$_gdb_message"
> >  }
> >}
> 
> Why not just use:
> 
> set msg "breakpoint on Foo::Bar"
> gdb_test_multiple "break Foo::Bar" {
> ... fail "$msg ...
> }
> 
> I don't think the ``$_gdb_message'' is right.  It certainly isn't 
> exactly intuative.

No, it certainly isn't.  The problem is that the other cases internally
need to know the msg; the only way to do it as above would be to
document a _required_ variable named $msg.  This works, of course:

set msg "breakpoint on Foo::Bar"
gdb_test_multiple "break Foo::Bar" "breakpoint on Foo::Bar" {
... fail "$msg ...
}

I want to think about this a little more anyway; as Michael mentioned,
I don't think it's recursion safe.  I can't fix this syntax due to TCL
limitations, so it might become:

gdb_test_multiple "break Foo::Bar" "breakpoint on Foo::Bar" \
  "Breakpoint at .*\[\r\n\]$gdb_prompt $" { pass $msg } \
  "Bang." { kfail "gdb/90211" $msg }

Which isn't so bad, after all.  I had some reason not to do it that way
but I can't remember what it was, now.  What do you think of this
change?


-- 
Daniel Jacobowitz
MontaVista Software                         Debian GNU/Linux Developer

Re: RFC: gdb_test_multiple

[Andrew Cagney]

> gdb_test_multiple "break Foo::Bar" "breakpoint on Foo::Bar" {
>   -re "Breakpoint at .*\[\r\n\]$gdb_prompt $" {
>     pass "$_gdb_message"
>   }
>   -re "Explode!" {
>     fail "$_gdb_message (gdb/90210)"
>   }
>   -re "Bang." {
>     kfail "gdb/90211" "$_gdb_message"
>   }
> }

Why not just use:

set msg "breakpoint on Foo::Bar"
gdb_test_multiple "break Foo::Bar" {
... fail "$msg ...
}

I don't think the ``$_gdb_message'' is right.  It certainly isn't 
exactly intuative.

Andrew

Re: RFC: gdb_test_multiple

[Michael Elizabeth Chastain]

Sounds great.  I am running a Sunday build+test now, which will finish
Sunday evening.  Then this will be next on my work list.  Among other
things, I will test it with both tcl/expect/dejagnu stacks
(the stock releases that I use / the sourceware dejagnu package,
which has its own version of tcl and expect).

> See the _gdb_message bit?  That, _gdb_command, and _gdb_result are set
> in the caller's scope.

Will this work with nested gdb_test_multiple's?  People do that occasionally,
although personally I eschew the practice.
 
> A friend of mine got so fed up with TCL that he rewrote DejaGNU in
> Perl, which he's planning to publish in the next couple of weeks.
> I can see why.

I would be very interested in that but it's a separate line item.

One note about the implementation: could you rename gdb_standard_send
to _gdb_standard_send or gdb_internal_standard_send or something else
that puts more psychological differnce between the exported functions
and the internal functions.

Michael C

RFC: gdb_test_multiple

[Daniel Jacobowitz]

After a duel with TCL, I return triumphant (but seriously injured; I took a
blow to the head that may never heal...).  This patch adds a new function
gdb_test_multiple, which works like this:

gdb_test_multiple "break Foo::Bar" "breakpoint on Foo::Bar" {
  -re "Breakpoint at .*\[\r\n\]$gdb_prompt $" {
    pass "$_gdb_message"
  }
  -re "Explode!" {
    fail "$_gdb_message (gdb/90210)"
  }
  -re "Bang." {
    kfail "gdb/90211" "$_gdb_message"
  }
}

That represents a problem, for which two PRs were filed, one of which is
currently KFAIL'd and the other of which we believe is fixed.  How's it look
to everyone?

It does one truly gross thing, by the way.  See the _gdb_message bit?  That,
_gdb_command, and _gdb_result are set in the caller's scope.  This is
because of certain quoting limitations in TCL which prevented me from doing
it any better way.  It's ironic; the language has no form of lindex which
does not perform backslash escaping, and no way to get items out of a list
without stripping their outer "" or {}.  A friend of mine got so fed up with
TCL that he rewrote DejaGNU in Perl, which he's planning to publish in the
next couple of weeks.  I can see why.

The grossness doesn't affect gdb_test since gdb_test doesn't uplevel the
call to gdb_standard_expect; it's only something to be aware of for new uses
of gdb_test_multiple.

I'm going to sit on this patch until Tuesday, for comments about both the
interface and the implementation; ideas welcome.  After that I plan to
commit it so that Michael C can go wild using it.  The committed version
will include a comment update that I forgot in the below, clarifying that
you do need the "-re" bit just like gdb_expect.

-- 
Daniel Jacobowitz
MontaVista Software                         Debian GNU/Linux Developer

2003-01-04  Daniel Jacobowitz  <drow@mvista.com>

	* lib/gdb.exp (gdb_standard_expect, gdb_standard_send): New
	functions, broken out from gdb_test.  Display the TCL errorInfo
	in the expect error/eof block if set.
	(gdb_test): Use them.
	(gdb_test_multiple): New function.

Index: lib/gdb.exp
===================================================================
RCS file: /cvs/src/src/gdb/testsuite/lib/gdb.exp,v
retrieving revision 1.30
diff -u -p -r1.30 gdb.exp
--- lib/gdb.exp	16 Dec 2002 19:33:54 -0000	1.30
+++ lib/gdb.exp	4 Jan 2003 20:03:06 -0000
@@ -1,4 +1,5 @@
-# Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000
+# Copyright 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
+# 2002, 2003
 # Free Software Foundation, Inc.
 
 # This program is free software; you can redistribute it and/or modify
@@ -358,56 +359,12 @@ proc gdb_continue_to_breakpoint {name} {
     }
 }
 
-
-
-# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE
-# Send a command to gdb; test the result.
-#
-# COMMAND is the command to execute, send to GDB with send_gdb.  If
-#   this is the null string no command is sent.
-# PATTERN is the pattern to match for a PASS, and must NOT include
-#   the \r\n sequence immediately before the gdb prompt.
-# MESSAGE is an optional message to be printed.  If this is
-#   omitted, then the pass/fail messages use the command string as the
-#   message.  (If this is the empty string, then sometimes we don't
-#   call pass or fail at all; I don't understand this at all.)
-# QUESTION is a question GDB may ask in response to COMMAND, like
-#   "are you sure?"
-# RESPONSE is the response to send if QUESTION appears.
-#
-# Returns:
-#    1 if the test failed,
-#    0 if the test passes,
-#   -1 if there was an internal error.
-#  
-proc gdb_test { args } {
-    global verbose
-    global gdb_prompt
-    global GDB
-    upvar timeout timeout
-
-    if [llength $args]>2 then {
-	set message [lindex $args 2]
-    } else {
-	set message [lindex $args 0]
-    }
-    set command [lindex $args 0]
-    set pattern [lindex $args 1]
-
-    if [llength $args]==5 {
-	set question_string [lindex $args 3];
-	set response_string [lindex $args 4];
-    } else {
-	set question_string "^FOOBAR$"
-    }
-
-    if $verbose>2 then {
-	send_user "Sending \"$command\" to gdb\n"
-	send_user "Looking to match \"$pattern\"\n"
-	send_user "Message is \"$message\"\n"
-    }
-
-    set result -1
+### gdb_standard_send COMMAND MESSAGE
+###
+### Send a (possibly multiline) COMMAND to GDB.  If an error is
+### encountered, fail with MESSAGE.  This is an internal helper
+### for gdb_test and should not be used from testcases.
+proc gdb_standard_send { command message } {
     set string "${command}\n";
     if { $command != "" } {
 	while { "$string" != "" } {
@@ -422,7 +379,7 @@ proc gdb_test { args } {
 			perror "Couldn't send $command to GDB.";
 		    }
 		    fail "$message";
-		    return $result;
+		    return -1;
 		}
 		# since we're checking if each line of the multi-line
 		# command are 'accepted' by GDB here,
@@ -446,11 +403,28 @@ proc gdb_test { args } {
 		    perror "Couldn't send $command to GDB.";
 		}
 		fail "$message";
-		return $result;
+		return -1;
 	    }
 	}
     }
+    return 0
+}
+
+### gdb_standard_expect COMMAND MESSAGE CODE
+###
+### Like gdb_expect, but also matching a set of standard patterns.
+### This plays games with uplevel, so the variables _GDB_COMMAND, _GDB_MESSAGE,
+### and _GDB_RESULT will be set in the calling procedure.  GDB_PROMPT will be
+### globalized in the above procedure, also.
+### The return value is whatever gets assigned to _GDB_RESULT.
+### This is an internal helper for gdb_test and gdb_test_multiple and should not
+### be called directly.
+proc gdb_standard_expect {command message code} {
+    global errorInfo
+    set errorInfo ""
 
+    # Infer a timeout.
+    uplevel {if {[info exists timeout]} { } else { upvar timeout timeout }}
     if [target_info exists gdb,timeout] {
 	set tmt [target_info gdb,timeout];
     } else {
@@ -465,104 +439,234 @@ proc gdb_test { args } {
 	    }
 	}
     }
-    gdb_expect $tmt {
-	 -re "\\*\\*\\* DOSEXIT code.*" {
-	     if { $message != "" } {
-		 fail "$message";
-	     }
-	     gdb_suppress_entire_file "GDB died";
-	     return -1;
-	 }
-	 -re "Ending remote debugging.*$gdb_prompt $" {
+
+    set before {
+	-re "\\*\\*\\* DOSEXIT code.*" {
+	    if { $_gdb_message != "" } {
+		fail "$_gdb_message";
+	    }
+	    gdb_suppress_entire_file "GDB died";
+	    set _gdb_result -1;
+	}
+	-re "Ending remote debugging.*$gdb_prompt $" {
 	    if ![isnative] then {
 		warning "Can`t communicate to remote target."
 	    }
 	    gdb_exit
 	    gdb_start
-	    set result -1
-	}
-	 -re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" {
-	    if ![string match "" $message] then {
-		pass "$message"
-	    }
-	    set result 0
-	}
-	 -re "(${question_string})$" {
-	    send_gdb "$response_string\n";
-	    exp_continue;
-	}
-	 -re "Undefined\[a-z\]* command:.*$gdb_prompt $" {
-	    perror "Undefined command \"$command\"."
-            fail "$message"
-	    set result 1
-	}
-	 -re "Ambiguous command.*$gdb_prompt $" {
-	    perror "\"$command\" is not a unique command name."
-            fail "$message"
-	    set result 1
+	    set _gdb_result -1
 	}
-	 -re "Program exited with code \[0-9\]+.*$gdb_prompt $" {
-	    if ![string match "" $message] then {
-		set errmsg "$message: the program exited"
+    }
+    set after {
+	-re "Undefined\[a-z\]* command:.*$gdb_prompt $" {
+	    perror "Undefined command \"$_gdb_command\"."
+	    fail "$_gdb_message"
+	    set _gdb_result 1
+	}
+	-re "Ambiguous command.*$gdb_prompt $" {
+	    perror "\"$_gdb_command\" is not a unique command name."
+	    fail "$_gdb_message"
+	    set _gdb_result 1
+	}
+	-re "Program exited with code \[0-9\]+.*$gdb_prompt $" {
+	    if ![string match "" $_gdb_message] then {
+		set _gdb_errmsg "$_gdb_message: the program exited"
 	    } else {
-		set errmsg "$command: the program exited"
+		set _gdb_errmsg "$_gdb_command: the program exited"
 	    }
-	    fail "$errmsg"
-	    return -1
+	    fail "$_gdb_errmsg"
+	    set _gdb_result -1
 	}
-	 -re "EXIT code \[0-9\r\n\]+Program exited normally.*$gdb_prompt $" {
-	    if ![string match "" $message] then {
-		set errmsg "$message: the program exited"
+	-re "EXIT code \[0-9\r\n\]+Program exited normally.*$gdb_prompt $" {
+	    if ![string match "" $_gdb_message] then {
+		set _gdb_errmsg "$_gdb_message: the program exited"
 	    } else {
-		set errmsg "$command: the program exited"
+		set _gdb_errmsg "$_gdb_command: the program exited"
 	    }
-	    fail "$errmsg"
-	    return -1
+	    fail "$_gdb_errmsg"
+	    set _gdb_result -1
 	}
-	 -re "The program is not being run.*$gdb_prompt $" {
-	    if ![string match "" $message] then {
-		set errmsg "$message: the program is no longer running"
+	-re "The program is not being run.*$gdb_prompt $" {
+	    if ![string match "" $_gdb_message] then {
+		set _gdb_errmsg "$_gdb_message: the program is no longer running"
 	    } else {
-		set errmsg "$command: the program is no longer running"
+		set _gdb_errmsg "$_gdb_command: the program is no longer running"
 	    }
-	    fail "$errmsg"
-	    return -1
+	    fail "$_gdb_errmsg"
+	    set _gdb_result -1
 	}
-	 -re ".*$gdb_prompt $" {
-	    if ![string match "" $message] then {
-		fail "$message"
+	-re ".*$gdb_prompt $" {
+	    if ![string match "" $_gdb_message] then {
+		fail "$_gdb_message"
 	    }
-	    set result 1
+	    set _gdb_result 1
 	}
-	 "<return>" {
+	"<return>" {
 	    send_gdb "\n"
 	    perror "Window too small."
-            fail "$message"
+	    fail "$_gdb_message"
 	}
-	 -re "\\(y or n\\) " {
+	-re "\\(y or n\\) " {
 	    send_gdb "n\n"
 	    perror "Got interactive prompt."
-            fail "$message"
+	    fail "$_gdb_message"
 	}
-	 eof {
-	     perror "Process no longer exists"
-	     if { $message != "" } {
-		 fail "$message"
-	     }
-	     return -1
+	eof {
+	    global errorInfo
+	    if {[info exists errorInfo] && $errorInfo != ""} {
+		perror "TCL error: $errorInfo"
+	    } else {
+		perror "Process no longer exists"
+	    }
+	    if { $_gdb_message != "" } {
+		 fail "$_gdb_message"
+	    }
+	    set _gdb_result -1
 	}
-	 full_buffer {
+	full_buffer {
 	    perror "internal buffer is full."
-            fail "$message"
+	    fail "$_gdb_message"
 	}
 	timeout	{
+	    if ![string match "" $_gdb_message] then {
+		fail "$_gdb_message (timeout)"
+	    }
+	    set _gdb_result 1
+	}
+    }
+
+    upvar _gdb_result _gdb_result
+    set _gdb_result 0
+
+    set body "gdb_expect $tmt {[concat $before $code $after]}"
+
+    # We need to get _gdb_message and _gdb_command into the namespace above
+    # us.  There's no good way to do this in TCL; this will work as long
+    # as they don't have unbalanced braces.
+    uplevel "set _gdb_message {$message}"
+    uplevel "set _gdb_command {$command}"
+
+    uplevel "global gdb_prompt"
+    uplevel $body
+
+    return $_gdb_result
+}
+
+# gdb_test COMMAND PATTERN MESSAGE QUESTION RESPONSE
+# Send a command to gdb; test the result.
+#
+# COMMAND is the command to execute, send to GDB with send_gdb.  If
+#   this is the null string no command is sent.
+# PATTERN is the pattern to match for a PASS, and must NOT include
+#   the \r\n sequence immediately before the gdb prompt.
+# MESSAGE is an optional message to be printed.  If this is
+#   omitted, then the pass/fail messages use the command string as the
+#   message.  (If this is the empty string, then sometimes we don't
+#   call pass or fail at all; I don't understand this at all.)
+# QUESTION is a question GDB may ask in response to COMMAND, like
+#   "are you sure?"
+# RESPONSE is the response to send if QUESTION appears.
+#
+# Returns:
+#    1 if the test failed,
+#    0 if the test passes,
+#   -1 if there was an internal error.
+#  
+proc gdb_test { args } {
+    global verbose
+    global gdb_prompt
+    global GDB
+    upvar timeout timeout
+
+    if [llength $args]>2 then {
+	set message [lindex $args 2]
+    } else {
+	set message [lindex $args 0]
+    }
+    set command [lindex $args 0]
+    set pattern [lindex $args 1]
+
+    if [llength $args]==5 {
+	set question_string [lindex $args 3];
+	set response_string [lindex $args 4];
+    } else {
+	set question_string "^FOOBAR$"
+    }
+
+    if $verbose>2 then {
+	send_user "Sending \"$command\" to gdb\n"
+	send_user "Looking to match \"$pattern\"\n"
+	send_user "Message is \"$message\"\n"
+    }
+
+    set result [gdb_standard_send $command $message]
+    if {$result == -1} {
+	return -1
+    }
+
+    gdb_standard_expect $command $message {
+	-re "\[\r\n\]*($pattern)\[\r\n\]+$gdb_prompt $" {
 	    if ![string match "" $message] then {
-		fail "$message (timeout)"
+		pass "$message"
 	    }
-	    set result 1
+	    set _gdb_result 0
+	}
+	 -re "(${question_string})$" {
+	    send_gdb "$response_string\n";
+	    exp_continue;
 	}
     }
-    return $result
+
+    return $_gdb_result
+}
+
+# gdb_test_multiple COMMAND MESSAGE {PATTERN RESPONSE [PATTERN RESPONSE]...}
+# Send a command to gdb; test the result.
+#
+# COMMAND is the command to execute, send to GDB with send_gdb.  If
+#   this is the null string no command is sent.
+# MESSAGE is a message to be printed in pass/fail responses.  If this is
+#   the empty string then the pass/fail messages use the command string as the
+#   message.
+# For each following pair in the third list:
+#  PATTERN is the complete pattern to match for a PASS.  Unlike for gdb_test,
+#    this pattern should include the \r\n sequence and final prompt.
+#  RESPONSE is a block of code to be executed for PATTERN.  The code will
+#    be executed in the context of the caller; _GDB_COMMAND and _GDB_MESSAGE
+#    are available in the block, and setting _GDB_RESULT will control the
+#     return value of gdb_test_multiple.
+#
+# Note that _GDB_COMMAND, _GDB_MESSAGE, and _GDB_RESULT are set in the caller's
+# scope; see gdb_standard_expect.
+#
+# Returns:
+#    The value assigned to _GDB_RESULT if by a provided RESPONSE, if any
+#    1 if the test failed,
+#    0 if the test passes, or if a provided RESPONSE matched and did not
+#      set _GDB_RESULT.
+#   -1 if there was an internal error.
+#  
+proc gdb_test_multiple { command message code } {
+    global verbose
+    global gdb_prompt
+    global GDB
+    upvar timeout timeout
+
+    if {$message == ""} {
+	set message $command
+    }
+
+    if $verbose>2 then {
+	send_user "Sending \"$command\" to gdb\n"
+	send_user "Message is \"$message\"\n"
+    }
+
+    set result [gdb_standard_send $command $message]
+    if {$result == -1} {
+	return -1
+    }
+
+    return [uplevel gdb_standard_expect \{$command\} \{$message\} \{$code\}]
 }
 \f
 # Test that a command gives an error.  For pass or fail, return