* lib/mi-support.exp (varobj_tree): New namespace and procs.
(mi_varobj_tree_test_children_callback): New proc. (mi_walk_varobj_tree): New proc.
This commit is contained in:
Keith Seitz
parent
3d7bb9d9ca
commit
1eec78bdad
2 changed files with 316 additions and 0 deletions
|
|
@ -1,3 +1,9 @@
|
||||||
|
2011-11-23 Keith Seitz <keiths@redhat.com>
|
||||||
|
|
||||||
|
* lib/mi-support.exp (varobj_tree): New namespace and procs.
|
||||||
|
(mi_varobj_tree_test_children_callback): New proc.
|
||||||
|
(mi_walk_varobj_tree): New proc.
|
||||||
|
|
||||||
2011-11-22 Tom Tromey <tromey@redhat.com>
|
2011-11-22 Tom Tromey <tromey@redhat.com>
|
||||||
|
|
||||||
* lib/mi-support.exp (mi_run_cmd_full): Rename from mi_run_cmd.
|
* lib/mi-support.exp (mi_run_cmd_full): Rename from mi_run_cmd.
|
||||||
|
|
|
||||||
|
|
@ -1944,3 +1944,313 @@ proc mi_get_features {} {
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
# Variable Object Trees
|
||||||
|
#
|
||||||
|
# Yet another way to check varobjs. Pass mi_walk_varobj_tree a "list" of
|
||||||
|
# variables (not unlike the actual source code definition), and it will
|
||||||
|
# automagically test the children for you (by default).
|
||||||
|
#
|
||||||
|
# Example:
|
||||||
|
#
|
||||||
|
# source code:
|
||||||
|
# struct bar {
|
||||||
|
# union {
|
||||||
|
# int integer;
|
||||||
|
# void *ptr;
|
||||||
|
# };
|
||||||
|
# const int *iPtr;
|
||||||
|
# };
|
||||||
|
#
|
||||||
|
# class foo {
|
||||||
|
# public:
|
||||||
|
# int a;
|
||||||
|
# struct {
|
||||||
|
# int b;
|
||||||
|
# struct bar *c;
|
||||||
|
# };
|
||||||
|
# };
|
||||||
|
#
|
||||||
|
# foo *f = new foo (); <-- break here
|
||||||
|
#
|
||||||
|
# We want to check all the children of "f".
|
||||||
|
#
|
||||||
|
# Translate the above structures into the following tree:
|
||||||
|
#
|
||||||
|
# set tree {
|
||||||
|
# foo f {
|
||||||
|
# {} public {
|
||||||
|
# int a {}
|
||||||
|
# anonymous struct {
|
||||||
|
# {} public {
|
||||||
|
# int b {}
|
||||||
|
# {bar *} c {
|
||||||
|
# {} public {
|
||||||
|
# anonymous union {
|
||||||
|
# {} public {
|
||||||
|
# int integer {}
|
||||||
|
# {void *} ptr {}
|
||||||
|
# }
|
||||||
|
# }
|
||||||
|
# {const int *} iPtr {
|
||||||
|
# {const int} {*iPtr} {}
|
||||||
|
# }
|
||||||
|
# }
|
||||||
|
# }
|
||||||
|
# }
|
||||||
|
# }
|
||||||
|
# }
|
||||||
|
# }
|
||||||
|
# }
|
||||||
|
#
|
||||||
|
# mi_walk_varobj_tree $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
|
||||||
|
# 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
|
||||||
|
# structures like linked lists.
|
||||||
|
|
||||||
|
namespace eval ::varobj_tree {
|
||||||
|
# An index which is appended to root varobjs to ensure uniqueness.
|
||||||
|
variable _root_idx 0
|
||||||
|
|
||||||
|
# A procedure to help with debuggging varobj trees.
|
||||||
|
# VARIABLE_NAME is the name of the variable to dump.
|
||||||
|
# CMD, if present, is the name of the callback to output the contstructed
|
||||||
|
# strings. By default, it uses expect's "send_log" command.
|
||||||
|
# TERM, if present, is a terminating character. By default it is the newline.
|
||||||
|
#
|
||||||
|
# To output to the terminal (not the expect log), use
|
||||||
|
# mi_varobj_tree_dump_variable my_variable puts ""
|
||||||
|
|
||||||
|
proc mi_varobj_tree_dump_variable {variable_name {cmd send_log} {term "\n"}} {
|
||||||
|
upvar #0 $variable_name varobj
|
||||||
|
|
||||||
|
eval "$cmd \"VAR = $variable_name$term\""
|
||||||
|
|
||||||
|
# Explicitly encode the array indices, since outputting them
|
||||||
|
# in some logical order is better than what "array names" might
|
||||||
|
# return.
|
||||||
|
foreach idx {obj_name parent display_name type path_expr} {
|
||||||
|
eval "$cmd \"\t$idx = $varobj($idx)$term\""
|
||||||
|
}
|
||||||
|
|
||||||
|
# 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.
|
||||||
|
#
|
||||||
|
# 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 {}
|
||||||
|
foreach child $varobj(children) {
|
||||||
|
upvar #0 $child c
|
||||||
|
set clist [list [string_to_regexp $c(obj_name)] \
|
||||||
|
[string_to_regexp $c(display_name)] \
|
||||||
|
[llength $c(children)]]
|
||||||
|
if {[string length $c(type)] > 0} {
|
||||||
|
lappend clist [string_to_regexp $c(type)]
|
||||||
|
}
|
||||||
|
lappend children_list $clist
|
||||||
|
}
|
||||||
|
|
||||||
|
mi_list_varobj_children $varobj(obj_name) $children_list \
|
||||||
|
"VT: list children of $varobj(obj_name)"
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# Set the properties of the varobj represented by
|
||||||
|
# PARENT_VARIABLE - the name of the parent's variable
|
||||||
|
# OBJNAME - the MI object name of this variable
|
||||||
|
# DISP_NAME - the display name of this variable
|
||||||
|
# TYPE - the type of this variable
|
||||||
|
# PATH - the path expression for this variable
|
||||||
|
# CHILDREN - a list of the variable's children
|
||||||
|
proc create_varobj {parent_variable objname disp_name \
|
||||||
|
type path children} {
|
||||||
|
upvar #0 $parent_variable parent
|
||||||
|
|
||||||
|
set var_name "root.$objname"
|
||||||
|
global $var_name
|
||||||
|
array set $var_name [list obj_name $objname]
|
||||||
|
array set $var_name [list display_name $disp_name]
|
||||||
|
array set $var_name [list type $type]
|
||||||
|
array set $var_name [list path_expr $path]
|
||||||
|
array set $var_name [list parent "$parent_variable"]
|
||||||
|
array set $var_name [list children \
|
||||||
|
[get_tree_children $var_name $children]]
|
||||||
|
return $var_name
|
||||||
|
}
|
||||||
|
|
||||||
|
# Should VARIABLE be used in path expressions? The CPLUS_FAKE_CHILD
|
||||||
|
# varobjs and anonymous structs/unions are not used for path expressions.
|
||||||
|
proc is_path_expr_parent {variable} {
|
||||||
|
upvar #0 $variable varobj
|
||||||
|
|
||||||
|
# If the varobj's type is "", it is a CPLUS_FAKE_CHILD.
|
||||||
|
# If the tail of the varobj's object name is "%d_anonymous",
|
||||||
|
# then it represents an anonymous struct or union.
|
||||||
|
if {[string length $varobj(type)] == 0 \
|
||||||
|
|| [regexp {[0-9]+_anonymous$} $varobj(obj_name)]} {
|
||||||
|
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
|
||||||
|
|
||||||
|
# If TYPE is "", this is one of the CPLUS_FAKE_CHILD varobjs,
|
||||||
|
# which has no path expression
|
||||||
|
if {[string length $type] == 0} {
|
||||||
|
return ""
|
||||||
|
}
|
||||||
|
|
||||||
|
# Find the path parent variable.
|
||||||
|
while {![is_path_expr_parent $parent_variable]} {
|
||||||
|
set parent_variable $parent(parent)
|
||||||
|
upvar #0 $parent_variable parent
|
||||||
|
}
|
||||||
|
|
||||||
|
return "(($parent(path_expr)).$name)"
|
||||||
|
}
|
||||||
|
|
||||||
|
# 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 {
|
||||||
|
if {[string compare $parent_variable "root"] == 0} {
|
||||||
|
# Root variable
|
||||||
|
variable _root_idx
|
||||||
|
incr _root_idx
|
||||||
|
set objname "$name$_root_idx"
|
||||||
|
set disp_name "$name"
|
||||||
|
set path_expr "$name"
|
||||||
|
} elseif {[string compare $type "anonymous"] == 0} {
|
||||||
|
# Special case: anonymous types. In this case, NAME will either be
|
||||||
|
# "struct" or "union".
|
||||||
|
set objname "$parent(obj_name).${field_idx}_anonymous"
|
||||||
|
set disp_name "<anonymous $name>"
|
||||||
|
set path_expr ""
|
||||||
|
set type "$name {...}"
|
||||||
|
} else {
|
||||||
|
set objname "$parent(obj_name).$name"
|
||||||
|
set disp_name $name
|
||||||
|
set path_expr [get_path_expr $parent_variable $name $type]
|
||||||
|
}
|
||||||
|
|
||||||
|
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} {
|
||||||
|
global root
|
||||||
|
|
||||||
|
if {[llength $tree] < 3} {
|
||||||
|
error "tree does not contain enough elements"
|
||||||
|
}
|
||||||
|
|
||||||
|
# Create root node and process the tree.
|
||||||
|
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} {
|
||||||
|
# "Pop" the name of the global variable containing this varobj's
|
||||||
|
# information from the stack of nodes.
|
||||||
|
set var_name [lindex $all_nodes 0]
|
||||||
|
set all_nodes [lreplace $all_nodes 0 0]
|
||||||
|
|
||||||
|
# Bring the global named in VAR_NAME into scope as the local variable
|
||||||
|
# VAROBJ.
|
||||||
|
upvar #0 $var_name varobj
|
||||||
|
|
||||||
|
# Append any children of VAROBJ to the list of nodes to walk.
|
||||||
|
if {[llength $varobj(children)] > 0} {
|
||||||
|
set all_nodes [concat $all_nodes $varobj(children)]
|
||||||
|
}
|
||||||
|
|
||||||
|
# If this is a root variable, create the variable object for it.
|
||||||
|
if {[string compare $varobj(parent) "root"] == 0} {
|
||||||
|
mi_create_varobj $varobj(obj_name) $varobj(display_name) \
|
||||||
|
"VT: create root varobj for $varobj(display_name)"
|
||||||
|
}
|
||||||
|
|
||||||
|
# Now call the callback for VAROBJ.
|
||||||
|
uplevel #0 $callback $var_name
|
||||||
|
}
|
||||||
|
}
|
||||||
|
}
|
||||||
|
|
||||||
|
# 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
|
||||||
|
}
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue