This is the mail archive of the gdb-patches@sources.redhat.com mailing list for the GDB project.


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]
Other format: [Raw text]

[RFA] mi testsuite varobj support


Hi,

This "patch" adds support code to the testsuite to (partly) facilitate 
testing varobjs.

Comapred to my original RFC, this code whacks the command stuff, as
suggested by Fernando.

Keith

ChangeLog
2002-10-18  Keith Seitz  <keiths@redhat.com>

	* mi-varobj-support.exp: New file adding some varobj
	testing niceties.

Patch
Index: testsuite/lib/mi-varobj-support.exp
===================================================================
RCS file: testsuite/lib/mi-varobj-support.exp
diff -N testsuite/lib/mi-varobj-support.exp
*** testsuite/lib/mi-varobj-support.exp	1 Jan 1970 00:00:00 -0000
--- testsuite/lib/mi-varobj-support.exp	18 Oct 2002 17:38:41 -0000
***************
*** 0 ****
--- 1,267 ----
+ # MI Testsuite Support Routines for Varobj
+ # Contributed by Keith Seitz <keiths@redhat.com>
+ 
+ # Copyright 2002 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 2 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
+ # GNU General Public License for more details.
+ # 
+ # You should have received a copy of the GNU General Public License
+ # along with this program; if not, write to the Free Software
+ # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  
+ 
+ # Please email any bugs, comments, and/or additions to this file to:
+ # bug-gdb@prep.ai.mit.edu
+ 
+ # This module defines support routines that can be used by the MI
+ # testsuite to facilitate the testing of the varobj interface.
+ 
+ # The most basic varspec is simply a Tcl list of the variable's type, its
+ # "name" and a list of its children. For example, consider the following
+ # variable declaration in C:
+ #
+ # int foo;
+ #
+ # The varspec to fully describe this variable would be:
+ #
+ # set foo_varspec {
+ #   int foo {}
+ # }
+ #
+ # To get the MI testsuite to test the creation of this varobj, one would
+ # use the command Varobj::create with mi_gdb_test:
+ #
+ # mi_gdb_test "-var-create [lindex $foo_varspec 1] * [lindex $foo_varspec 1]" \
+ #   [Varobj::create $foo_varspec] \
+ #   "create varobj for foo"
+ #
+ # WARNING: The varobj MUST use the name "[lindex $VASPEC 1]" or none of this 
+ # will work.
+ 
+ # Consider a more complex example:
+ #
+ # class B
+ # {
+ # public:
+ #   int pub_b;
+ # protected:
+ #   char *prot_b;
+ # };
+ #
+ # class A : public B
+ # {
+ # public:
+ #   int pub_a;
+ # private:
+ #   int priv_a[3];
+ # };
+ #
+ # A varspec describing a variable "bar" of type "class A" would look like:
+ #
+ # set bar_varspec {
+ #   A bar {
+ #     B B {
+ #       public {
+ #         int pub_b {}
+ #       }
+ #       protected {
+ #         {char *} prot_b {
+ #           char *prot_b {}
+ #         }
+ #       }
+ #     }
+ #     {} public {
+ #       int pub_a {}
+ #     }
+ #     {} private {
+ #        {int [3]} priv_a {
+ #          int 0 {}
+ #          int 1 {}
+ #          int 2 {}
+ #        }
+ #      }
+ #    }
+ #  }
+ #
+ # To test the creation of this varobj, simply use:
+ # mi_gdb_test "-var-create [lindex $bar_varspec 1] * [lindex $bar_varspec 1]" \
+ #   [Varobj::create $bar_varspec] \
+ #   "create varobj for bar"
+ #
+ # To get this children of this varobj:
+ # mi_gdb_test "-var-list-children [lindex $bar_varspec 1]" \
+ #  [Varobj::children $bar_varspec] \
+ #  "get children of bar"
+ #
+ # To test getting the children of "B", simply use:
+ # mi_gdb_test "-var-list-children [lindex $bar_varspec 1].B" \
+ #   [Varobj::children pattern $bar_varspec B] \
+ #   "get children of bar.B"
+ #
+ # Finally, to get the children of one of the children of bar, specify
+ # the child's name as a period-delimited path through the varspec:
+ # mi_gdb_test "-var-list-children [lindex $bar_varspec 1].B.protected.prot_b] \
+ #   [Varobj::children pattern $bar_varspec B.protected.prot_b] \
+ #   "get children of bar.B.protected.prot_b"
+ 
+ namespace eval Varobj {
+ 
+   #  Name:         Varobj::create
+   #  Description:  Handles varobj creation
+   #  Synopsis:
+   #     Varobj::create patter
+   #
+   #  Arguments:
+   #        VARSPEC - Variable specification for varobj
+   proc create {varspec} {
+     return [_escape [eval _create_pattern [list $varspec]]]
+   }
+ 
+   #  Name:         Varobj::num_children
+   #  Description:  Handles queries for the varobj's number of children
+   #  Synopsis:
+   #     Varobj::num_chidlren VARSPEC [CHILD]
+   #
+   #  Arguments:
+   #        VARSPEC - Variable specification for varobj
+   #        CHILD   - Optional pathname of a child in the varobj
+   proc num_children {varspec args} {
+     return [_escape [eval _num_children_pattern [list $varspec] $args]]
+   }
+ 
+   #  Name:         Varobj::children
+   #  Description:  Handles queries for the varobj's children
+   #  Synopsis:
+   #     Varobj::chilren VARSPEC [CHILD]
+   #
+   #  Arguments:
+   #        VARSPEC - Variable specification for varobj
+   #        CHILD   - Optional pathname of a child in the varobj
+   proc children {varspec args} {
+     return [_escape [eval _children_pattern [list $varspec] $args]]
+   }
+ 
+   # ------------------------------------------------------------
+ 
+   #
+   # Functions used by the public interfaces above
+   #
+ 
+   # Returns the regexp pattern to be used by the testsuite:
+   # ^done,name="name",numchild="numchild",type="type"
+   proc _create_pattern {varspec} {
+     set type [lindex $varspec 0]
+     set exp [lindex $varspec 1]
+     set numchild [_varobj_num_children $varspec]
+     return [format {^done,name="%s",numchild="%d",type="%s"} \
+ 	      $exp $numchild $type]
+   }
+ 
+   # Returns the regexp pattern to be used by the testsuite:
+   # ^done,numchild="numchild"
+   proc _num_children_pattern {varspec {child {}}} {
+     set numchild [_varobj_num_children $varspec $child]
+     return [format {^done,numchild="%d"} $numchild]
+   }
+ 
+   # Returns the regexp pattern to be used by the testsuite:
+   # ^done,children={child={name="name",exp="expr",numchild="numchild"[,type="type"],...}}
+   proc _children_pattern {varspec {child {}}} {
+     set children [_varobj_children $varspec $child]
+     set numchild [_num_children $children]
+     set result "^done,numchild=\"[_num_children $children]\""
+     if {$numchild > 0} {
+       append result ",children=\{"
+     }
+     foreach {type exp kids} $children {
+       set name [_varobj_name $varspec $child]
+       append result "child=\{name=\"${name}.$exp\""
+       append result ",exp=\"$exp\",numchild=\"[_num_children $kids]\""
+       if {$type != ""} {
+ 	append result ",type=\"$type\""
+       }
+       append result "\},"
+     }
+     if {$numchild > 0} {
+       set result [string trim $result ,]
+       append result "\}"
+     }
+     return $result
+   }
+ 
+   #
+   # Varobj functions
+   #
+   
+   # Returns the varobj name for the given child (baz.bar.foo, not foo)
+   proc _varobj_name {varspec {child {}}} {
+     set name [lindex $varspec 1]
+     if {$child != ""} {
+       append name ".$child"
+     }
+     return $name
+   }
+ 
+   # Returns the expression name (foo, not baz.bar.foo)
+   proc _varobj_exp {varspec {child {}}} {
+     return [lindex [split [_varobj_name $varspec $child] .] end]
+   }
+ 
+   # Returns the number of children for a given variable/child
+   proc _varobj_num_children {varspec {child {}}} {
+     set children [_varobj_children $varspec $child]
+     return [_num_children $children]
+   }
+ 
+   proc _num_children {childList} {
+     # The total number of children is one-third the length of
+     # this children list. (Remember each variable/child has
+     # THREE elements in the list: type, name, and childrenList.)
+     return [expr {[llength $childList] / 3}]
+   }
+ 
+   # Gets the children for a given variable and child. Children
+   # are a period-delimited list of child names, eg. foo.bar is
+   # the child "bar" of the child "foo" of the root varobj.
+   proc _varobj_children {varspec {child {}}} {
+ 
+     # Set result to children of root
+     set children [lindex $varspec 2]
+ 
+     if {$child != {}} {
+ 
+       # Want a specific child. Loop through and find it.
+       foreach c [split $child .] {
+ 
+ 	# Loop through all the children looking for the child "$c"
+ 	foreach {type name kids} $children {
+ 	  if {[string compare $name $c] == 0} {
+ 	    set children $kids
+ 	  }
+ 	}
+       }
+     }
+ 
+     return $children
+   }
+ 
+   # This will escape all of expect's reserved regexp characters
+   # in the given STRING.
+   proc _escape {string} {
+     if {[info tclversion] >= 8.1} {
+       set expr {([\[\].*^])}
+     } else {
+       set expr "(\[\]\[.*^\])"
+     }
+     regsub -all -- $expr $string \
+       {[format {\\%c} [scan {\1} %c x; set x]]} newval
+     return [subst -nobackslashes -novariables $newval]
+   }
+ }


Index Nav: [Date Index] [Subject Index] [Author Index] [Thread Index]
Message Nav: [Date Prev] [Date Next] [Thread Prev] [Thread Next]