diff options
Diffstat (limited to 'gdb/gdbtk/generic/gdbtk-varobj.c')
| -rw-r--r-- | gdb/gdbtk/generic/gdbtk-varobj.c | 615 |
1 files changed, 0 insertions, 615 deletions
diff --git a/gdb/gdbtk/generic/gdbtk-varobj.c b/gdb/gdbtk/generic/gdbtk-varobj.c deleted file mode 100644 index 3496d229116..00000000000 --- a/gdb/gdbtk/generic/gdbtk-varobj.c +++ /dev/null @@ -1,615 +0,0 @@ -/* Variable user interface layer for GDB, the GNU debugger. - Copyright 1999, 2000, 2001, 2002 Free Software Foundation, Inc. - - This file is part of GDB. - - 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. */ - -#include "defs.h" -#include "value.h" -#include "gdb_string.h" -#include "varobj.h" - -#include <tcl.h> -#include "gdbtk.h" -#include "gdbtk-cmds.h" - -/* - * Public functions defined in this file - */ - -int gdb_variable_init (Tcl_Interp *); - -/* - * Private functions defined in this file - */ - -/* Entries into this file */ - -static int gdb_variable_command (ClientData, Tcl_Interp *, int, - Tcl_Obj * CONST[]); - -static int variable_obj_command (ClientData, Tcl_Interp *, int, - Tcl_Obj * CONST[]); - -/* Variable object subcommands */ - -static int variable_create (Tcl_Interp *, int, Tcl_Obj * CONST[]); - -static void variable_delete (Tcl_Interp *, struct varobj *, int); - -static Tcl_Obj *variable_children (Tcl_Interp *, struct varobj *); - -static int variable_format (Tcl_Interp *, int, Tcl_Obj * CONST[], - struct varobj *); - -static int variable_type (Tcl_Interp *, int, Tcl_Obj * CONST[], - struct varobj *); - -static int variable_value (Tcl_Interp *, int, Tcl_Obj * CONST[], - struct varobj *); - -static Tcl_Obj *variable_update (Tcl_Interp * interp, struct varobj **var); - -/* Helper functions for the above subcommands. */ - -static void install_variable (Tcl_Interp *, char *); - -static void uninstall_variable (Tcl_Interp *, char *); - -/* String representations of gdb's format codes */ -static char *format_string[] = - {"natural", "binary", "decimal", "hexadecimal", "octal"}; - - -/* Initialize the variable code. This function should be called once - to install and initialize the variable code into the interpreter. */ -int -gdb_variable_init (Tcl_Interp *interp) -{ - Tcl_Command result; - static int initialized = 0; - - if (!initialized) - { - result = Tcl_CreateObjCommand (interp, "gdb_variable", gdbtk_call_wrapper, - (ClientData) gdb_variable_command, NULL); - if (result == NULL) - return TCL_ERROR; - - initialized = 1; - } - - return TCL_OK; -} - -/* This function defines the "gdb_variable" command which is used to - create variable objects. Its syntax includes: - - gdb_variable create - gdb_variable create NAME - gdb_variable create -expr EXPR - gdb_variable create -frame FRAME - (it will also include permutations of the above options) - - NAME = name of object to create. If no NAME, then automatically create - a name - EXPR = the gdb expression for which to create a variable. This will - be the most common usage. - FRAME = the frame defining the scope of the variable. -*/ -static int -gdb_variable_command (ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) -{ - static const char *commands[] = - {"create", "list", NULL}; - enum commands_enum - { - VARIABLE_CREATE, VARIABLE_LIST - }; - int index, result; - - if (objc < 2) - { - Tcl_WrongNumArgs (interp, 1, objv, "option ?arg...?"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObj (interp, objv[1], commands, "options", 0, - &index) != TCL_OK) - { - return TCL_ERROR; - } - - switch ((enum commands_enum) index) - { - case VARIABLE_CREATE: - result = variable_create (interp, objc - 2, objv + 2); - break; - - default: - return TCL_ERROR; - } - - return result; -} - -/* This function implements the actual object command for each - variable object that is created (and each of its children). - - Currently the following commands are implemented: - - delete delete this object and its children - - update update the variable and its children (root vars only) - - numChildren how many children does this object have - - children create the children and return a list of their objects - - name print out the name of this variable - - format query/set the display format of this variable - - type get the type of this variable - - value get/set the value of this variable - - editable is this variable editable? -*/ -static int -variable_obj_command (ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *CONST objv[]) -{ - enum commands_enum - { - VARIABLE_DELETE, - VARIABLE_NUM_CHILDREN, - VARIABLE_CHILDREN, - VARIABLE_FORMAT, - VARIABLE_TYPE, - VARIABLE_VALUE, - VARIABLE_NAME, - VARIABLE_EDITABLE, - VARIABLE_UPDATE - }; - static const char *commands[] = - { - "delete", - "numChildren", - "children", - "format", - "type", - "value", - "name", - "editable", - "update", - NULL - }; - struct varobj *var; - char *varobj_name; - int index, result; - - /* Get the current handle for this variable token (name). */ - varobj_name = Tcl_GetStringFromObj (objv[0], NULL); - if (varobj_name == NULL) - return TCL_ERROR; - var = varobj_get_handle (varobj_name); - - - if (objc < 2) - { - Tcl_WrongNumArgs (interp, 1, objv, "option ?arg...?"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObj (interp, objv[1], commands, "options", 0, - &index) != TCL_OK) - return TCL_ERROR; - - result = TCL_OK; - switch ((enum commands_enum) index) - { - case VARIABLE_DELETE: - if (objc > 2) - { - int len; - char *s = Tcl_GetStringFromObj (objv[2], &len); - if (*s == 'c' && strncmp (s, "children", len) == 0) - { - variable_delete (interp, var, 1 /* only children */ ); - break; - } - } - variable_delete (interp, var, 0 /* var and children */ ); - break; - - case VARIABLE_NUM_CHILDREN: - Tcl_SetObjResult (interp, Tcl_NewIntObj (varobj_get_num_children (var))); - break; - - case VARIABLE_CHILDREN: - { - Tcl_Obj *children = variable_children (interp, var); - Tcl_SetObjResult (interp, children); - } - break; - - case VARIABLE_FORMAT: - result = variable_format (interp, objc, objv, var); - break; - - case VARIABLE_TYPE: - result = variable_type (interp, objc, objv, var); - break; - - case VARIABLE_VALUE: - result = variable_value (interp, objc, objv, var); - break; - - case VARIABLE_NAME: - { - char *name = varobj_get_expression (var); - Tcl_SetObjResult (interp, Tcl_NewStringObj (name, -1)); - xfree (name); - } - break; - - case VARIABLE_EDITABLE: - Tcl_SetObjResult (interp, - Tcl_NewIntObj (varobj_get_attributes (var) & 0x00000001 /* Editable? */ )); - break; - - case VARIABLE_UPDATE: - /* Only root variables can be updated */ - { - Tcl_Obj *obj = variable_update (interp, &var); - Tcl_SetObjResult (interp, obj); - } - break; - - default: - return TCL_ERROR; - } - - return result; -} - -/* - * Variable object construction/destruction - */ - -/* This function is responsible for processing the user's specifications - and constructing a variable object. */ -static int -variable_create (Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) -{ - enum create_opts - { - CREATE_EXPR, CREATE_FRAME - }; - static const char *create_options[] = - {"-expr", "-frame", NULL}; - struct varobj *var; - char *name; - char *obj_name; - int index; - CORE_ADDR frame = (CORE_ADDR) -1; - int how_specified = USE_SELECTED_FRAME; - - /* REMINDER: This command may be invoked in the following ways: - gdb_variable create [NAME] [-expr EXPR] [-frame FRAME] - - NAME = name of object to create. If no NAME, then automatically create - a name - EXPR = the gdb expression for which to create a variable. This will - be the most common usage. - FRAME = the address of the frame defining the variable's scope - */ - name = NULL; - if (objc) - name = Tcl_GetStringFromObj (objv[0], NULL); - if (name == NULL || *name == '-') - { - /* generate a name for this object */ - obj_name = varobj_gen_name (); - } - else - { - /* specified name for object */ - obj_name = strdup (name); - objv++; - objc--; - } - - /* Run through all the possible options for this command */ - name = NULL; - while (objc > 0) - { - if (Tcl_GetIndexFromObj (interp, objv[0], create_options, "options", - 0, &index) != TCL_OK) - { - xfree (obj_name); - result_ptr->flags |= GDBTK_IN_TCL_RESULT; - return TCL_ERROR; - } - - switch ((enum create_opts) index) - { - case CREATE_EXPR: - name = Tcl_GetStringFromObj (objv[1], NULL); - objc--; - objv++; - break; - - case CREATE_FRAME: - { - char *str; - str = Tcl_GetStringFromObj (objv[1], NULL); - frame = string_to_core_addr (str); - how_specified = USE_SPECIFIED_FRAME; - objc--; - objv++; - } - break; - - default: - break; - } - - objc--; - objv++; - } - - /* Create the variable */ - var = varobj_create (obj_name, name, frame, how_specified); - - if (var != NULL) - { - /* Install a command into the interpreter that represents this - object */ - install_variable (interp, obj_name); - Tcl_SetObjResult (interp, Tcl_NewStringObj (obj_name, -1)); - result_ptr->flags |= GDBTK_IN_TCL_RESULT; - - xfree (obj_name); - return TCL_OK; - } - - xfree (obj_name); - return TCL_ERROR; -} - -/* Delete the variable object VAR and its children */ -/* If only_children_p, Delete only the children associated with the object. */ -static void -variable_delete (Tcl_Interp *interp, struct varobj *var, - int only_children_p) -{ - char **dellist; - char **vc; - - varobj_delete (var, &dellist, only_children_p); - - vc = dellist; - while (*vc != NULL) - { - uninstall_variable (interp, *vc); - xfree (*vc); - vc++; - } - - xfree (dellist); -} - -/* Return a list of all the children of VAR, creating them if necessary. */ -static Tcl_Obj * -variable_children (Tcl_Interp *interp, struct varobj *var) -{ - Tcl_Obj *list; - struct varobj **childlist; - struct varobj **vc; - char *childname; - - list = Tcl_NewListObj (0, NULL); - - varobj_list_children (var, &childlist); - - vc = childlist; - while (*vc != NULL) - { - childname = varobj_get_objname (*vc); - /* Add child to result list and install the Tcl command for it. */ - Tcl_ListObjAppendElement (NULL, list, - Tcl_NewStringObj (childname, -1)); - install_variable (interp, childname); - vc++; - } - - xfree (childlist); - return list; -} - -/* Update the values for a variable and its children. */ -/* NOTE: Only root variables can be updated... */ - -static Tcl_Obj * -variable_update (Tcl_Interp *interp, struct varobj **var) -{ - Tcl_Obj *changed; - struct varobj **changelist; - struct varobj **vc; - - /* varobj_update() can return -1 if the variable is no longer around, - i.e. we stepped out of the frame in which a local existed. */ - if (varobj_update (var, &changelist) == -1) - return Tcl_NewStringObj ("-1", -1); - - changed = Tcl_NewListObj (0, NULL); - vc = changelist; - while (*vc != NULL) - { - /* Add changed variable object to result list */ - Tcl_ListObjAppendElement (NULL, changed, - Tcl_NewStringObj (varobj_get_objname (*vc), -1)); - vc++; - } - - xfree (changelist); - return changed; -} - -/* This implements the format object command allowing - the querying or setting of the object's display format. */ -static int -variable_format (Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[], struct varobj *var) -{ - if (objc > 2) - { - /* Set the format of VAR to given format */ - int len; - char *fmt = Tcl_GetStringFromObj (objv[2], &len); - if (strncmp (fmt, "natural", len) == 0) - varobj_set_display_format (var, FORMAT_NATURAL); - else if (strncmp (fmt, "binary", len) == 0) - varobj_set_display_format (var, FORMAT_BINARY); - else if (strncmp (fmt, "decimal", len) == 0) - varobj_set_display_format (var, FORMAT_DECIMAL); - else if (strncmp (fmt, "hexadecimal", len) == 0) - varobj_set_display_format (var, FORMAT_HEXADECIMAL); - else if (strncmp (fmt, "octal", len) == 0) - varobj_set_display_format (var, FORMAT_OCTAL); - else - { - gdbtk_set_result (interp, "unknown display format \"", - fmt, "\": must be: \"natural\", \"binary\"" - ", \"decimal\", \"hexadecimal\", or \"octal\""); - return TCL_ERROR; - } - } - else - { - /* Report the current format */ - Tcl_Obj *fmt; - - /* FIXME: Use varobj_format_string[] instead */ - fmt = Tcl_NewStringObj ( - format_string[(int) varobj_get_display_format (var)], -1); - Tcl_SetObjResult (interp, fmt); - } - - return TCL_OK; -} - -/* This function implements the type object command, which returns the type of a - variable in the interpreter (or an error). */ -static int -variable_type (Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[], struct varobj *var) -{ - const char *first; - const char *last; - char *string; - Tcl_RegExp regexp; - - /* For the "fake" variables, do not return a type. - Their type is NULL anyway */ - /* FIXME: varobj_get_type() calls type_print(), so we may have to wrap - its call here and return TCL_ERROR in the case it errors out */ - if ((string = varobj_get_type (var)) == NULL) - { - Tcl_ResetResult (interp); - return TCL_OK; - } - - first = string; - - /* gdb will print things out like "struct {...}" for anonymous structs. - In gui-land, we don't want the {...}, so we strip it here. */ - regexp = Tcl_RegExpCompile (interp, "{...}"); - if (Tcl_RegExpExec (interp, regexp, string, first)) - { - /* We have an anonymous struct/union/class/enum */ - Tcl_RegExpRange (regexp, 0, &first, &last); - if (*(first - 1) == ' ') - first--; - string[first - string] = '\0'; - } - - Tcl_SetObjResult (interp, Tcl_NewStringObj (string, -1)); - xfree (string); - return TCL_OK; -} - -/* This function implements the value object command, which allows an object's - value to be queried or set. */ -static int -variable_value (Tcl_Interp *interp, int objc, - Tcl_Obj *CONST objv[], struct varobj *var) -{ - char *r; - - /* If we're setting the value of the variable, objv[2] will contain the - variable's new value. */ - if (objc > 2) - { - /* FIXME: Do we need to test if val->error is set here? - If so, make it an attribute. */ - if (varobj_get_attributes (var) & 0x00000001 /* Editable? */ ) - { - char *s; - - s = Tcl_GetStringFromObj (objv[2], NULL); - if (!varobj_set_value (var, s)) - { - r = error_last_message(); - gdbtk_set_result (interp, "%s", r); - xfree (r); - return TCL_ERROR; - } - } - - Tcl_ResetResult (interp); - return TCL_OK; - } - - r = varobj_get_value (var); - - if (r == NULL) - { - char *err = error_last_message (); - gdbtk_set_result (interp, "%s", err); - xfree (err); - return TCL_ERROR; - } - else - { - Tcl_SetObjResult (interp, Tcl_NewStringObj (r, -1)); - xfree (r); - return TCL_OK; - } -} - -/* Helper functions for the above */ - -/* Install the given variable VAR into the tcl interpreter with - the object name NAME. */ -static void -install_variable (Tcl_Interp *interp, char *name) -{ - Tcl_CreateObjCommand (interp, name, variable_obj_command, - NULL, NULL); -} - -/* Unistall the object VAR in the tcl interpreter. */ -static void -uninstall_variable (Tcl_Interp *interp, char *varname) -{ - Tcl_DeleteCommand (interp, varname); -} - |