Merge GDB 7.5.1

gdb/testsuite/lib/mi-support.exp

 # Copyright 1999-2000, 2002-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
@@ skipping 13 matching lines @@
 if ![info exists mi_gdb_prompt] then {
     set mi_gdb_prompt "\[(\]gdb\[)\] \r\n"
 }
 
 global mi_inferior_spawn_id
 global mi_inferior_tty_name
 
 set MIFLAGS "-i=mi"
 
 set thread_selected_re "=thread-selected,id=\"\[0-9\]+\"\r\n"
-set library_loaded_re "=library-loaded\[^\n\]+\"\r\n"
+set gdbindex_warning_re "&\"warning: Skipping \[^\r\n\]+ \.gdb_index section in \[^\r\n\]+\"\r\n(?:&\"\\\\n\"\r\n)?"
+set library_loaded_re "=library-loaded\[^\n\]+\"\r\n(?:$gdbindex_warning_re)?"
 set breakpoint_re "=(?:breakpoint-created|breakpoint-deleted)\[^\n\]+\"\r\n"
 
 #
 # mi_gdb_exit -- exit the GDB, killing the target program if necessary
 #
 proc mi_gdb_exit {} {
     catch mi_uncatched_gdb_exit
 }
 
 proc mi_uncatched_gdb_exit {} {
@@ skipping 1008 matching lines @@
           }
         }
         return
     }
 
     set args "\\\[$args\\\]"
 
     set bn ""
     if { $reason == "breakpoint-hit" } {
         set bn {bkptno="[0-9]+",}
+    } elseif { $reason == "solib-event" } {
+        set bn ".*"
     }
 
     set r ""
     if { $reason != "" } {
         set r "reason=\"$reason\","
     }
 
 
     set a $after_reason
 
@@ skipping 215 matching lines @@
         } else {
             set er "$er,$v"
         }
     }
     set er "$er\\\]"
 
     verbose -log "Expecting: $er" 2
     mi_gdb_test "-var-update $name" $er $testname
 }
 
-proc mi_varobj_update_with_type_change { name new_type new_children testname } {
-    set v "{name=\"$name\",in_scope=\"true\",type_changed=\"true\",new_type=\"$new_type\",new_num_children=\"$new_children\",has_more=\".\"}"
+proc mi_varobj_update_with_child_type_change { name child_name new_type new_children testname } {
+    set v "{name=\"$child_name\",in_scope=\"true\",type_changed=\"true\",new_type=\"$new_type\",new_num_children=\"$new_children\",has_more=\".\"}"
     set er "\\^done,changelist=\\\[$v\\\]"
     verbose -log "Expecting: $er"
     mi_gdb_test "-var-update $name" $er $testname
 }
 
+proc mi_varobj_update_with_type_change { name new_type new_children testname } {
+    mi_varobj_update_with_child_type_change $name $name $new_type $new_children $testname
+}
+
 # A helper that turns a key/value list into a regular expression
 # matching some MI output.
 proc mi_varobj_update_kv_helper {list} {
     set first 1
     set rx ""
     foreach {key value} $list {
         if {!$first} {
             append rx ,
         }
         set first 0
@@ skipping 690 matching lines @@
 #                 {const int} {*iPtr} {}
 #               }
 #             }
 #           }
 #         }
 #       }
 #     }
 #   }
 # }
 #
-# mi_walk_varobj_tree $tree
+# mi_walk_varobj_tree c++ $tree
 #
 # If you'd prefer to walk the tree using your own callback,
 # simply pass the name of the callback to mi_walk_varobj_tree.
 #
 # This callback should take one argument, the name of the variable
 # to process.  This name is the name of a global array holding the
 # variable's properties (object name, type, etc).
 #
 # An example callback:
 #
 # proc my_callback {var} {
 #   upvar #0 $var varobj
 #
 #   puts "my_callback: called on varobj $varobj(obj_name)"
 # }
 #
 # The arrays created for each variable object contain the following
 # members:
 #
 # obj_name     - the object name for accessing this variable via MI
 # display_name - the display name for this variable (exp="display_name" in
 #                the output of -var-list-children)
 # type         - the type of this variable (type="type" in the output
 #                of -var-list-children, or the special tag "anonymous"
 # path_expr    - the "-var-info-path-expression" for this variable
+#                NOTE: This member cannot be used reliably with typedefs.
+#                Use with caution!
+#                See notes inside get_path_expr for more.
 # parent       - the variable name of the parent varobj
 # children     - a list of children variable names (which are the
 #                names Tcl arrays, not object names)
 #
 # For each variable object, an array containing the above fields will
 # be created under the root node (conveniently called, "root").  For example,
 # a variable object with handle "OBJ.public.0_anonymous.a" will have
 # a corresponding global Tcl variable named "root.OBJ.public.0_anonymous.a".
 #
 # Note that right now, this mechanism cannot be used for recursive data
@@ skipping 26 matching lines @@
 
     # Output children
     set num [llength $varobj(children)]
     eval "$cmd \"\tnum_children = $num$term\""
     if {$num > 0} {
       eval "$cmd \"\tchildren = $varobj(children)$term\""
     }
   }
 
   # The default callback used by mi_walk_varobj_tree.  This callback
-  # simply checks all of VAR's children.
+  # simply checks all of VAR's children.  It specifically does not test
+  # path expressions, since that is very problematic.
   #
   # This procedure may be used in custom callbacks.
   proc test_children_callback {variable_name} {
     upvar #0 $variable_name varobj
 
     if {[llength $varobj(children)] > 0} {
       # Construct the list of children the way mi_list_varobj_children
       # expects to get it:
       # { {obj_name display_name num_children type} ... }
       set children_list {}
@@ skipping 49 matching lines @@
       return false
     }
 
     return true
   }
 
   # Return the path expression for the variable named NAME in
   # parent varobj whose variable name is given by PARENT_VARIABLE.
   proc get_path_expr {parent_variable name type} {
     upvar #0 $parent_variable parent
+    upvar #0 $parent_variable path_parent
 
     # If TYPE is "", this is one of the CPLUS_FAKE_CHILD varobjs,
-    # which has no path expression
-    if {[string length $type] == 0} {
+    # which has no path expression.  Likewsise for anonymous structs
+    # and unions.
+    if {[string length $type] == 0 \
+            || [string compare $type "anonymous"] == 0} {
       return ""
     }
 
     # Find the path parent variable.
     while {![is_path_expr_parent $parent_variable]} {
-      set parent_variable $parent(parent)
-      upvar #0 $parent_variable parent
+      set parent_variable $path_parent(parent)
+      upvar #0 $parent_variable path_parent
     }
 
-    return "(($parent(path_expr)).$name)"
+    # This is where things get difficult.  We do not actually know
+    # the real type for variables defined via typedefs, so we don't actually
+    # know whether the parent is a structure/union or not.
+    #
+    # So we assume everything that isn't a simple type is a compound type.
+    set stars ""
+    regexp {\*+} $parent(type) stars
+    set is_compound 1
+    if {[string index $name 0] == "*"} {
+      set is_compound 0
+    }
+
+    if {[string index $parent(type) end] == "\]"} {
+      # Parent is an array.
+      return "($path_parent(path_expr))\[$name\]"
+    } elseif {$is_compound} {
+      # Parent is a structure or union or a pointer to one.
+      if {[string length $stars]} {
+        set join "->"
+      } else {
+        set join "."
+      }
+
+      global root
+
+      # To make matters even more hideous, varobj.c has slightly different
+      # path expressions for C and C++.
+      set path_expr "($path_parent(path_expr))$join$name"
+      if {[string compare -nocase $root(language) "c"] == 0} {
+        return $path_expr
+      } else {
+        return "($path_expr)"
+      }
+    } else {
+      # Parent is a pointer.
+      return "*($path_parent(path_expr))"
+    }
   }
 
   # Process the CHILDREN (a list of varobj_tree elements) of the variable
   # given by PARENT_VARIABLE.  Returns a list of children variables.
   proc get_tree_children {parent_variable children} {
     upvar #0 $parent_variable parent
 
     set field_idx 0
     set children_list {}
     foreach {type name children} $children {
@@ skipping 20 matching lines @@
       lappend children_list [create_varobj $parent_variable $objname \
                                  $disp_name $type $path_expr $children]
       incr field_idx
     }
 
     return $children_list
   }
 
   # The main procedure to call the given CALLBACK on the elements of the
   # given varobj TREE.  See detailed explanation above.
-  proc walk_tree {tree callback} {
+  proc walk_tree {language tree callback} {
     global root
 
     if {[llength $tree] < 3} {
       error "tree does not contain enough elements"
     }
 
     # Create root node and process the tree.
+    array set root [list language $language]
     array set root [list obj_name "root"]
     array set root [list display_name "root"]
     array set root [list type "root"]
     array set root [list path_expr "root"]
     array set root [list parent "root"]
     array set root [list children [get_tree_children root $tree]]
 
     # Walk the tree
     set all_nodes $root(children); # a stack of nodes
     while {[llength $all_nodes] > 0} {
@@ skipping 23 matching lines @@
   }
 }
 
 # The default varobj tree callback, which simply tests -var-list-children.
 proc mi_varobj_tree_test_children_callback {variable} {
   ::varobj_tree::test_children_callback $variable
 }
 
 # Walk the variable object tree given by TREE, calling the specified
 # CALLBACK.  By default this uses mi_varobj_tree_test_children_callback.
-proc mi_walk_varobj_tree {tree {callback \
-                                    mi_varobj_tree_test_children_callback}} {
-  ::varobj_tree::walk_tree $tree $callback
+proc mi_walk_varobj_tree {language tree \
+                              {callback \
+                                   mi_varobj_tree_test_children_callback}} {
+  ::varobj_tree::walk_tree $language $tree $callback
 }