Merge GDB 7.5.1

gdb/testsuite/lib/gdb.exp

 # Copyright 1992-2005, 2007-2012 Free Software Foundation, Inc.
 
 # This program is free software; you can redistribute it and/or modify
 # it under the terms of the GNU General Public License as published by
 # the Free Software Foundation; either version 3 of the License, or
 # (at your option) any later version.
 #
 # This program is distributed in the hope that it will be useful,
 # but WITHOUT ANY WARRANTY; without even the implied warranty of
 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
@@ skipping 34 matching lines @@
 # E.g. make check RUNTESTFLAGS=GDBFLAGS=mumble
 # Testcases may use it to add additional flags, but they must:
 # - append new flags, not overwrite
 # - restore the original value when done
 global GDBFLAGS
 if ![info exists GDBFLAGS] {
     set GDBFLAGS ""
 }
 verbose "using GDBFLAGS = $GDBFLAGS" 2
 
+# Make the build data directory available to tests.
+set BUILD_DATA_DIRECTORY "[pwd]/../data-directory"
+
 # INTERNAL_GDBFLAGS contains flags that the testsuite requires.
 global INTERNAL_GDBFLAGS
 if ![info exists INTERNAL_GDBFLAGS] {
-    set INTERNAL_GDBFLAGS "-nw -nx -data-directory [pwd]/../data-directory"
+    set INTERNAL_GDBFLAGS "-nw -nx -data-directory $BUILD_DATA_DIRECTORY"
 }
 
 # The variable gdb_prompt is a regexp which matches the gdb prompt.
 # Set it if it is not already set.
 global gdb_prompt
 if ![info exists gdb_prompt] then {
     set gdb_prompt "\[(\]gdb\[)\]"
 }
 
 # The variable fullname_syntax_POSIX is a regexp which matches a POSIX 
@@ skipping 190 matching lines @@
                         return;
                     }
                     send_gdb "jump *$start\n";
                 }
                 timeout {
                     perror "Jump to start() failed (timeout)"; 
                     return
                 }
             }
         }
-        if [target_info exists gdb_stub] {
-            gdb_expect 60 {
-                -re "$gdb_prompt $" {
-                    send_gdb "continue\n"
-                }
-            }
-        }
         return
     }
 
     if [target_info exists gdb,do_reload_on_run] {
         if { [gdb_reload] != 0 } {
             return;
         }
     }
     send_gdb "run $args\n"
 # This doesn't work quite right yet.
@@ skipping 19 matching lines @@
 
 proc gdb_start_cmd {args} {
     global gdb_prompt use_gdb_stub
 
     if [target_info exists gdb_init_command] {
         send_gdb "[target_info gdb_init_command]\n";
         gdb_expect 30 {
             -re "$gdb_prompt $" { }
             default {
                 perror "gdb_init_command for target failed";
-                return;
+                return -1;
             }
         }
     }
 
     if $use_gdb_stub {
         return -1
     }
 
     send_gdb "start $args\n"
     # Use -notransfer here so that test cases (like chng-sym.exp)
     # may test for additional start-up messages.
     gdb_expect 60 {
         -re "The program .* has been started already.*y or n. $" {
             send_gdb "y\n"
             exp_continue
         }
         -notransfer -re "Starting program: \[^\r\n\]*" {
             return 0
         }
     }
     return -1
 }
 
 # Set a breakpoint at FUNCTION.  If there is an additional argument it is
 # a list of options; the supported options are allow-pending, temporary,
-# and no-message.
+# message, no-message, and passfail.
+# The result is 1 for success, 0 for failure.
+#
+# Note: The handling of message vs no-message is messed up, but it's based
+# on historical usage.  By default this function does not print passes,
+# only fails.
+# no-message: turns off printing of fails (and passes, but they're already off)
+# message: turns on printing of passes (and fails, but they're already on)
 
 proc gdb_breakpoint { function args } {
     global gdb_prompt
     global decimal
 
     set pending_response n
-    if {[lsearch -exact [lindex $args 0] allow-pending] != -1} {
+    if {[lsearch -exact $args allow-pending] != -1} {
         set pending_response y
     }
 
     set break_command "break"
     set break_message "Breakpoint"
-    if {[lsearch -exact [lindex $args 0] temporary] != -1} {
+    if {[lsearch -exact $args temporary] != -1} {
         set break_command "tbreak"
         set break_message "Temporary breakpoint"
     }
 
-    set no_message 0
-    if {[lsearch -exact [lindex $args 0] no-message] != -1} {
-        set no_message 1
+    set print_pass 0
+    set print_fail 1
+    set no_message_loc [lsearch -exact $args no-message]
+    set message_loc [lsearch -exact $args message]
+    # The last one to appear in args wins.
+    if { $no_message_loc > $message_loc } {
+        set print_fail 0
+    } elseif { $message_loc > $no_message_loc } {
+        set print_pass 1
     }
 
+    set test_name "setting breakpoint at $function"
+
     send_gdb "$break_command $function\n"
     # The first two regexps are what we get with -g, the third is without -g.
     gdb_expect 30 {
         -re "$break_message \[0-9\]* at .*: file .*, line $decimal.\r\n$gdb_prompt $" {}
         -re "$break_message \[0-9\]*: file .*, line $decimal.\r\n$gdb_prompt $" {}
         -re "$break_message \[0-9\]* at .*$gdb_prompt $" {}
         -re "$break_message \[0-9\]* \\(.*\\) pending.*$gdb_prompt $" {
                 if {$pending_response == "n"} {
-                        if { $no_message == 0 } {
-                                fail "setting breakpoint at $function"
+                        if { $print_fail } {
+                                fail $test_name
                         }
                         return 0
                 }
         }
         -re "Make breakpoint pending.*y or \\\[n\\\]. $" { 
                 send_gdb "$pending_response\n"
                 exp_continue
         }
         -re "A problem internal to GDB has been detected" {
-                fail "setting breakpoint at $function in runto (GDB internal error)"
+                if { $print_fail } {
+                    fail "$test_name (GDB internal error)"
+                }
                 gdb_internal_error_resync
                 return 0
         }
         -re "$gdb_prompt $" {
-                if { $no_message == 0 } {
-                        fail "setting breakpoint at $function"
+                if { $print_fail } {
+                        fail $test_name
+                }
+                return 0
+        }
+        eof {
+                if { $print_fail } {
+                        fail "$test_name (eof)"
                 }
                 return 0
         }
         timeout {
-                if { $no_message == 0 } {
-                        fail "setting breakpoint at $function (timeout)"
+                if { $print_fail } {
+                        fail "$test_name (timeout)"
                 }
                 return 0
         }
     }
+    if { $print_pass } {
+        pass $test_name
+    }
     return 1;
 }    
 
 # Set breakpoint at function and run gdb until it breaks there.
 # Since this is the only breakpoint that will be set, if it stops
 # at a breakpoint, we will assume it is the one we want.  We can't
 # just compare to "function" because it might be a fully qualified,
-# single quoted C++ function specifier.  If there's an additional argument,
-# pass it to gdb_breakpoint.
+# single quoted C++ function specifier.
+#
+# If there are additional arguments, pass them to gdb_breakpoint.
+# We recognize no-message/message ourselves.
+# The default is no-message.
+# no-message is messed up here, like gdb_breakpoint: to preserve
+# historical usage fails are always printed by default.
+# no-message: turns off printing of fails (and passes, but they're already off)
+# message: turns on printing of passes (and fails, but they're already on)
 
 proc runto { function args } {
     global gdb_prompt
     global decimal
 
     delete_breakpoints
 
-    if ![gdb_breakpoint $function [lindex $args 0]] {
+    # Default to "no-message".
+    set args "no-message $args"
+
+    set print_pass 0
+    set print_fail 1
+    set no_message_loc [lsearch -exact $args no-message]
+    set message_loc [lsearch -exact $args message]
+    # The last one to appear in args wins.
+    if { $no_message_loc > $message_loc } {
+        set print_fail 0
+    } elseif { $message_loc > $no_message_loc } {
+        set print_pass 1
+    }
+
+    set test_name "running to $function in runto"
+
+    # We need to use eval here to pass our varargs args to gdb_breakpoint
+    # which is also a varargs function.
+    # But we also have to be careful because $function may have multiple
+    # elements, and we don't want Tcl to move the remaining elements after
+    # the first to $args.  That is why $function is wrapped in {}.
+    if ![eval gdb_breakpoint {$function} $args] {
         return 0;
     }
 
     gdb_run_cmd
     
     # the "at foo.c:36" output we get with -g.
     # the "in func" output we get without -g.
     gdb_expect 30 {
         -re "Break.* at .*:$decimal.*$gdb_prompt $" {
+            if { $print_pass } {
+                pass $test_name
+            }
             return 1
         }
         -re "Breakpoint \[0-9\]*, \[0-9xa-f\]* in .*$gdb_prompt $" { 
+            if { $print_pass } {
+                pass $test_name
+            }
             return 1
         }
         -re "The target does not support running in non-stop mode.\r\n$gdb_prompt $" {
-            unsupported "Non-stop mode not supported"
+            if { $print_fail } {
+                unsupported "Non-stop mode not supported"
+            }
             return 0
         }
         -re ".*A problem internal to GDB has been detected" {
-            fail "running to $function in runto (GDB internal error)"
+            if { $print_fail } {
+                fail "$test_name (GDB internal error)"
+            }
             gdb_internal_error_resync
             return 0
         }
         -re "$gdb_prompt $" { 
-            fail "running to $function in runto"
+            if { $print_fail } {
+                fail $test_name
+            }
             return 0
         }
         eof { 
-            fail "running to $function in runto (end of file)"
+            if { $print_fail } {
+                fail "$test_name (eof)"
+            }
             return 0
         }
         timeout { 
-            fail "running to $function in runto (timeout)"
+            if { $print_fail } {
+                fail "$test_name (timeout)"
+            }
             return 0
         }
     }
     return 1
 }
 
 # Ask gdb to run until we hit a breakpoint at main.
-# The case where the target uses stubs has to be handled
-# specially--if it uses stubs, assuming we hit
-# breakpoint() and just step out of the function.
 #
 # N.B. This function deletes all existing breakpoints.
 # If you don't want that, use gdb_start_cmd.
 
 proc runto_main { } {
-    global gdb_prompt
-    global decimal
-
-    if ![target_info exists gdb_stub] {
-        return [runto main]
-    }                   
-
-    delete_breakpoints
-
-    gdb_step_for_stub;
-
-    return 1
+    return [runto main no-message]
 }
 
 ### Continue, and expect to hit a breakpoint.
 ### Report a pass or fail, depending on whether it seems to have
 ### worked.  Use NAME as part of the test name; each call to
 ### continue_to_breakpoint should use a NAME which is unique within
 ### that test file.
 proc gdb_continue_to_breakpoint {name {location_pattern .*}} {
     global gdb_prompt
     set full_name "continue to breakpoint: $name"
 
     send_gdb "continue\n"
     gdb_expect {
-        -re "Breakpoint .* (at|in) $location_pattern\r\n$gdb_prompt $" {
+        -re "(?:Breakpoint|Temporary breakpoint) .* (at|in) $location_pattern\r\n$gdb_prompt $" {
             pass $full_name
         }
         -re ".*$gdb_prompt $" {
             fail $full_name
         }
         timeout { 
             fail "$full_name (timeout)"
         }
     }
 }
@@ skipping 18 matching lines @@
 #     ...
 #     -re ".*A problem internal to GDB has been detected" {
 #         gdb_internal_error_resync
 #     }
 #     ...
 # }
 #
 proc gdb_internal_error_resync {} {
     global gdb_prompt
 
+    verbose -log "Resyncing due to internal error."
+
     set count 0
     while {$count < 10} {
         gdb_expect {
             -re "Quit this debugging session\\? \\(y or n\\) $" {
                 send_gdb "n\n"
                 incr count
             }
             -re "Create a core file of GDB\\? \\(y or n\\) $" {
                 send_gdb "n\n"
                 incr count
@@ skipping 59 matching lines @@
 
     if [string match "*\[\r\n\]" $command] {
         error "Invalid trailing newline in \"$message\" test"
     }
 
     if [string match "*\[\r\n\]*" $message] {
         error "Invalid newline in \"$message\" test"
     }
 
     if {$use_gdb_stub
-        && [regexp -nocase {^\s*(r|run|star|start|at|att|atta|attac|attach)\M} \
+        && [regexp -nocase {^\s*(r|run|star|start|at|att|atta|attac|attach)\M} \
             $command]} {
         error "gdbserver does not support $command without extended-remote"
     }
 
     # TCL/EXPECT WART ALERT
     # Expect does something very strange when it receives a single braced
     # argument.  It splits it along word separators and performs substitutions.
     # This means that { "[ab]" } is evaluated as "[ab]", but { "\[ab\]" } is
     # evaluated as "\[ab\]".  But that's not how TCL normally works; inside a
     # double-quoted list item, "\[ab\]" is just a long way of representing
@@ skipping 119 matching lines @@
             global timeout;
             if [info exists timeout] {
                 set tmt $timeout;
             } else {
                 set tmt 60;
             }
         }
     }
 
     set code {
-         -re ".*A problem internal to GDB has been detected" {
-             fail "$message (GDB internal error)"
-             gdb_internal_error_resync
-         }
-         -re "\\*\\*\\* DOSEXIT code.*" {
-             if { $message != "" } {
-                 fail "$message";
-             }
-             gdb_suppress_entire_file "GDB died";
-             set result -1;
-         }
+        -re ".*A problem internal to GDB has been detected" {
+            fail "$message (GDB internal error)"
+            gdb_internal_error_resync
+        }
+        -re "\\*\\*\\* DOSEXIT code.*" {
+            if { $message != "" } {
+                fail "$message";
+            }
+            gdb_suppress_entire_file "GDB died";
+            set result -1;
+        }
     }
     append code $processed_code
     append code {
-         -re "Ending remote debugging.*$gdb_prompt $" {
+        -re "Ending remote debugging.*$gdb_prompt $" {
             if ![isnative] then {
                 warning "Can`t communicate to remote target."
             }
             gdb_exit
             gdb_start
             set result -1
         }
-         -re "Undefined\[a-z\]* command:.*$gdb_prompt $" {
+        -re "Undefined\[a-z\]* command:.*$gdb_prompt $" {
             perror "Undefined command \"$command\"."
-            fail "$message"
+            fail "$message"
             set result 1
         }
-         -re "Ambiguous command.*$gdb_prompt $" {
+        -re "Ambiguous command.*$gdb_prompt $" {
             perror "\"$command\" is not a unique command name."
-            fail "$message"
+            fail "$message"
             set result 1
         }
-         -re "$inferior_exited_re with code \[0-9\]+.*$gdb_prompt $" {
+        -re "$inferior_exited_re with code \[0-9\]+.*$gdb_prompt $" {
             if ![string match "" $message] then {
                 set errmsg "$message (the program exited)"
             } else {
                 set errmsg "$command (the program exited)"
             }
             fail "$errmsg"
             set result -1
         }
-         -re "$inferior_exited_re normally.*$gdb_prompt $" {
+        -re "$inferior_exited_re normally.*$gdb_prompt $" {
             if ![string match "" $message] then {
                 set errmsg "$message (the program exited)"
             } else {
                 set errmsg "$command (the program exited)"
             }
             fail "$errmsg"
             set result -1
         }
-         -re "The program is not being run.*$gdb_prompt $" {
+        -re "The program is not being run.*$gdb_prompt $" {
             if ![string match "" $message] then {
                 set errmsg "$message (the program is no longer running)"
             } else {
                 set errmsg "$command (the program is no longer running)"
             }
             fail "$errmsg"
             set result -1
         }
-         -re "\r\n$gdb_prompt $" {
+        -re "\r\n$gdb_prompt $" {
             if ![string match "" $message] then {
                 fail "$message"
             }
             set result 1
         }
-         "<return>" {
+        "<return>" {
             send_gdb "\n"
             perror "Window too small."
-            fail "$message"
+            fail "$message"
             set result -1
         }
         -re "\\((y or n|y or \\\[n\\\]|\\\[y\\\] or n)\\) " {
             send_gdb "n\n"
             gdb_expect -re "$gdb_prompt $"
             fail "$message (got interactive prompt)"
             set result -1
         }
         -re "\\\[0\\\] cancel\r\n\\\[1\\\] all.*\r\n> $" {
             send_gdb "0\n"
             gdb_expect -re "$gdb_prompt $"
             fail "$message (got breakpoint menu)"
             set result -1
         }
-         eof {
-             perror "Process no longer exists"
-             if { $message != "" } {
-                 fail "$message"
-             }
-             return -1
+        eof {
+            perror "Process no longer exists"
+            if { $message != "" } {
+                fail "$message"
+            }
+            return -1
         }
-         full_buffer {
+        full_buffer {
             perror "internal buffer is full."
-            fail "$message"
+            fail "$message"
             set result -1
         }
         timeout {
             if ![string match "" $message] then {
                 fail "$message (timeout)"
             }
             set result 1
         }
     }
 
@@ skipping 597 matching lines @@
 
     return [skip_cplus_tests]
 }
 
 # Return a 1 if I don't even want to try to test FORTRAN.
 
 proc skip_fortran_tests {} {
     return 0
 }