summaryrefslogtreecommitdiff
path: root/gdb/gdbtk/generic/gdbtk-cmds.c
diff options
context:
space:
mode:
Diffstat (limited to 'gdb/gdbtk/generic/gdbtk-cmds.c')
-rw-r--r--gdb/gdbtk/generic/gdbtk-cmds.c3031
1 files changed, 0 insertions, 3031 deletions
diff --git a/gdb/gdbtk/generic/gdbtk-cmds.c b/gdb/gdbtk/generic/gdbtk-cmds.c
deleted file mode 100644
index ab3e1cc982b..00000000000
--- a/gdb/gdbtk/generic/gdbtk-cmds.c
+++ /dev/null
@@ -1,3031 +0,0 @@
-/* Tcl/Tk command definitions for Insight.
- Copyright 1994, 1995, 1996, 1997, 1998, 1999, 2001, 2002, 2003
- Free Software Foundation, Inc.
-
- Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
- Substantially augmented by Martin Hunt, Keith Seitz & Jim Ingham of
- Cygnus Support.
-
- 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 "inferior.h"
-#include "source.h"
-#include "symfile.h"
-#include "objfiles.h"
-#include "gdbcore.h"
-#include "demangle.h"
-#include "linespec.h"
-#include "tui/tui-file.h"
-#include "top.h"
-#include "annotate.h"
-#include "block.h"
-
-/* tcl header files includes varargs.h unless HAS_STDARG is defined,
- but gdb uses stdarg.h, so make sure HAS_STDARG is defined. */
-#define HAS_STDARG 1
-
-#include <itcl.h>
-#include <tcl.h>
-#include <tk.h>
-
-#include "guitcl.h"
-#include "gdbtk.h"
-#include "gdbtk-wrapper.h"
-#include "gdbtk-cmds.h"
-
-#include <signal.h>
-#include <fcntl.h>
-#include <sys/ioctl.h>
-#include <sys/time.h>
-#include <sys/stat.h>
-
-#include "gdb_string.h"
-#include "dis-asm.h"
-#include "gdbcmd.h"
-
-#ifdef HAVE_CTYPE_H
-#include <ctype.h> /* for isprint() */
-#endif
-
-/* Various globals we reference. */
-extern char *source_path;
-
-/* These two objects hold boolean true and false,
- and are shared by all the list objects that gdb_listfuncs
- returns. */
-
-static Tcl_Obj *mangled, *not_mangled;
-
-/* These two control how the GUI behaves when gdb is either tracing or loading.
- They are used in this file & gdbtk_hooks.c */
-
-int No_Update = 0;
-int load_in_progress = 0;
-
-/* This Structure is used in gdb_disassemble_driver.
- We need a different sort of line table from the normal one cuz we can't
- depend upon implicit line-end pc's for lines to do the
- reordering in this function. */
-
-struct my_line_entry
-{
- int line;
- CORE_ADDR start_pc;
- CORE_ADDR end_pc;
-};
-
-/* Use this to pass the Tcl Text widget command and the open file
- descriptor to the disassembly load command. */
-
-struct disassembly_client_data
-{
- FILE *fp;
- int file_opened_p;
- int widget_line_no;
- Tcl_Interp *interp;
- char *widget;
- Tcl_Obj *result_obj[3];
- const char *asm_argv[14];
- const char *source_argv[7];
- char *map_arr;
- Tcl_DString src_to_line_prefix;
- Tcl_DString pc_to_line_prefix;
- Tcl_DString line_to_pc_prefix;
- Tcl_CmdInfo cmd;
-};
-
-/* This variable determines where memory used for disassembly is read from.
- * See note in gdbtk.h for details.
- */
-int disassemble_from_exec = -1;
-
-extern int gdb_variable_init (Tcl_Interp * interp);
-
-/*
- * Declarations for routines exported from this file
- */
-
-int Gdbtk_Init (Tcl_Interp * interp);
-
-/*
- * Declarations for routines used only in this file.
- */
-
-static int compare_lines (const PTR, const PTR);
-static int comp_files (const void *, const void *);
-static int gdb_clear_file (ClientData, Tcl_Interp * interp, int,
- Tcl_Obj * CONST[]);
-static int gdb_cmd (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_confirm_quit (ClientData, Tcl_Interp *, int,
- Tcl_Obj * CONST[]);
-static int gdb_entry_point (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_eval (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_find_file_command (ClientData, Tcl_Interp *, int,
- Tcl_Obj * CONST objv[]);
-static int gdb_force_quit (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_get_file_command (ClientData, Tcl_Interp *, int,
- Tcl_Obj * CONST objv[]);
-static int gdb_get_function_command (ClientData, Tcl_Interp *, int,
- Tcl_Obj * CONST objv[]);
-static int gdb_get_line_command (ClientData, Tcl_Interp *, int,
- Tcl_Obj * CONST objv[]);
-static int gdb_update_mem (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_set_mem (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_immediate_command (ClientData, Tcl_Interp *, int,
- Tcl_Obj * CONST[]);
-static int gdb_incr_addr (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_CA_to_TAS (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_listfiles (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_listfuncs (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_loadfile (ClientData, Tcl_Interp *, int,
- Tcl_Obj * CONST objv[]);
-static int gdb_load_disassembly (ClientData clientData, Tcl_Interp
- * interp, int objc, Tcl_Obj * CONST objv[]);
-static int gdb_get_inferior_args (ClientData clientData,
- Tcl_Interp *interp,
- int objc, Tcl_Obj * CONST objv[]);
-static int gdb_set_inferior_args (ClientData clientData,
- Tcl_Interp *interp,
- int objc, Tcl_Obj * CONST objv[]);
-static int gdb_load_info (ClientData, Tcl_Interp *, int,
- Tcl_Obj * CONST objv[]);
-static int gdb_loc (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_path_conv (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_prompt_command (ClientData, Tcl_Interp *, int,
- Tcl_Obj * CONST objv[]);
-static int gdb_restore_fputs (ClientData, Tcl_Interp *, int,
- Tcl_Obj * CONST[]);
-static int gdb_search (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST objv[]);
-static int gdb_stop (ClientData, Tcl_Interp *, int, Tcl_Obj * CONST[]);
-static int gdb_target_has_execution_command (ClientData,
- Tcl_Interp *, int,
- Tcl_Obj * CONST[]);
-static int gdbtk_dis_asm_read_memory (bfd_vma, bfd_byte *, unsigned int,
- disassemble_info *);
-static void gdbtk_load_source (ClientData clientData,
- struct symtab *symtab,
- int start_line, int end_line);
-static CORE_ADDR gdbtk_load_asm (ClientData clientData, CORE_ADDR pc,
- struct disassemble_info *di);
-static int gdb_disassemble_driver (CORE_ADDR low, CORE_ADDR high,
- int mixed_source_and_assembly,
- ClientData clientData,
- void (*print_source_fn) (ClientData, struct
- symtab *, int,
- int),
- CORE_ADDR (*print_asm_fn) (ClientData,
- CORE_ADDR,
- struct
- disassemble_info
- *));
-char *get_prompt (void);
-static int perror_with_name_wrapper (PTR args);
-static int wrapped_call (PTR opaque_args);
-static int hex2bin (const char *hex, char *bin, int count);
-static int fromhex (int a);
-
-
-/* Gdbtk_Init
- * This loads all the Tcl commands into the Tcl interpreter.
- *
- * Arguments:
- * interp - The interpreter into which to load the commands.
- *
- * Result:
- * A standard Tcl result.
- */
-
-int
-Gdbtk_Init (Tcl_Interp *interp)
-{
- Tcl_CreateObjCommand (interp, "gdb_cmd", gdbtk_call_wrapper, gdb_cmd, NULL);
- Tcl_CreateObjCommand (interp, "gdb_immediate", gdbtk_call_wrapper,
- gdb_immediate_command, NULL);
- Tcl_CreateObjCommand (interp, "gdb_loc", gdbtk_call_wrapper, gdb_loc, NULL);
- Tcl_CreateObjCommand (interp, "gdb_path_conv", gdbtk_call_wrapper, gdb_path_conv,
- NULL);
- Tcl_CreateObjCommand (interp, "gdb_listfiles", gdbtk_call_wrapper, gdb_listfiles,
- NULL);
- Tcl_CreateObjCommand (interp, "gdb_listfuncs", gdbtk_call_wrapper, gdb_listfuncs,
- NULL);
- Tcl_CreateObjCommand (interp, "gdb_entry_point", gdbtk_call_wrapper,
- gdb_entry_point, NULL);
- Tcl_CreateObjCommand (interp, "gdb_update_mem", gdbtk_call_wrapper, gdb_update_mem,
- NULL);
- Tcl_CreateObjCommand (interp, "gdb_set_mem", gdbtk_call_wrapper, gdb_set_mem,
- NULL);
- Tcl_CreateObjCommand (interp, "gdb_stop", gdbtk_call_wrapper, gdb_stop, NULL);
- Tcl_CreateObjCommand (interp, "gdb_restore_fputs", gdbtk_call_wrapper, gdb_restore_fputs,
- NULL);
- Tcl_CreateObjCommand (interp, "gdb_eval", gdbtk_call_wrapper, gdb_eval, NULL);
- Tcl_CreateObjCommand (interp, "gdb_incr_addr", gdbtk_call_wrapper, gdb_incr_addr, NULL);
- Tcl_CreateObjCommand (interp, "gdb_CA_to_TAS", gdbtk_call_wrapper, gdb_CA_to_TAS, NULL);
- Tcl_CreateObjCommand (interp, "gdb_clear_file", gdbtk_call_wrapper,
- gdb_clear_file, NULL);
- Tcl_CreateObjCommand (interp, "gdb_confirm_quit", gdbtk_call_wrapper,
- gdb_confirm_quit, NULL);
- Tcl_CreateObjCommand (interp, "gdb_force_quit", gdbtk_call_wrapper,
- gdb_force_quit, NULL);
- Tcl_CreateObjCommand (interp, "gdb_target_has_execution",
- gdbtk_call_wrapper,
- gdb_target_has_execution_command, NULL);
- Tcl_CreateObjCommand (interp, "gdb_load_info", gdbtk_call_wrapper, gdb_load_info,
- NULL);
- Tcl_CreateObjCommand (interp, "gdb_get_function", gdbtk_call_wrapper,
- gdb_get_function_command, NULL);
- Tcl_CreateObjCommand (interp, "gdb_get_line", gdbtk_call_wrapper,
- gdb_get_line_command, NULL);
- Tcl_CreateObjCommand (interp, "gdb_get_file", gdbtk_call_wrapper,
- gdb_get_file_command, NULL);
- Tcl_CreateObjCommand (interp, "gdb_prompt",
- gdbtk_call_wrapper, gdb_prompt_command, NULL);
- Tcl_CreateObjCommand (interp, "gdb_find_file",
- gdbtk_call_wrapper, gdb_find_file_command, NULL);
- Tcl_CreateObjCommand (interp, "gdb_loadfile", gdbtk_call_wrapper, gdb_loadfile,
- NULL);
- Tcl_CreateObjCommand (interp, "gdb_load_disassembly", gdbtk_call_wrapper,
- gdb_load_disassembly, NULL);
- Tcl_CreateObjCommand (gdbtk_interp, "gdb_search", gdbtk_call_wrapper,
- gdb_search, NULL);
- Tcl_CreateObjCommand (interp, "gdb_get_inferior_args", gdbtk_call_wrapper,
- gdb_get_inferior_args, NULL);
- Tcl_CreateObjCommand (interp, "gdb_set_inferior_args", gdbtk_call_wrapper,
- gdb_set_inferior_args, NULL);
-
- /* gdb_context is used for debugging multiple threads or tasks */
- Tcl_LinkVar (interp, "gdb_context_id",
- (char *) &gdb_context,
- TCL_LINK_INT | TCL_LINK_READ_ONLY);
-
- /* Make gdb's notion of the pwd visible. This is read-only because
- (1) it doesn't make sense to change it directly and (2) it is
- allocated using xmalloc and not Tcl_Alloc. You might think we
- could just use the Tcl `pwd' command. However, Tcl (erroneously,
- imho) maintains a cache of the current directory name, and
- doesn't provide a way for gdb to invalidate the cache. */
- Tcl_LinkVar (interp, "gdb_current_directory",
- (char *) &current_directory,
- TCL_LINK_STRING | TCL_LINK_READ_ONLY);
-
- /* Current gdb source file search path. This is read-only for
- reasons similar to those for gdb_current_directory. */
- Tcl_LinkVar (interp, "gdb_source_path",
- (char *) &source_path,
- TCL_LINK_STRING | TCL_LINK_READ_ONLY);
-
- /* Init variable interface... */
- if (gdb_variable_init (interp) != TCL_OK)
- return TCL_ERROR;
-
- /* Init breakpoint module */
- if (Gdbtk_Breakpoint_Init (interp) != TCL_OK)
- return TCL_ERROR;
-
- /* Init stack module */
- if (Gdbtk_Stack_Init (interp) != TCL_OK)
- return TCL_ERROR;
-
- /* Init register module */
- if (Gdbtk_Register_Init (interp) != TCL_OK)
- return TCL_ERROR;
-
- /* Determine where to disassemble from */
- Tcl_LinkVar (gdbtk_interp, "disassemble-from-exec",
- (char *) &disassemble_from_exec,
- TCL_LINK_INT);
-
- Tcl_PkgProvide (interp, "Gdbtk", GDBTK_VERSION);
- return TCL_OK;
-}
-
-/* This routine acts as a top-level for all GDB code called by Tcl/Tk. It
- handles cleanups, and uses catch_errors to trap calls to return_to_top_level
- (usually via error).
- This is necessary in order to prevent a longjmp out of the bowels of Tk,
- possibly leaving things in a bad state. Since this routine can be called
- recursively, it needs to save and restore the contents of the result_ptr as
- necessary. */
-
-int
-gdbtk_call_wrapper (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- struct wrapped_call_args wrapped_args;
- gdbtk_result new_result, *old_result_ptr;
- int wrapped_returned_error = 0;
-
- old_result_ptr = result_ptr;
- result_ptr = &new_result;
- result_ptr->obj_ptr = Tcl_NewObj ();
- result_ptr->flags = GDBTK_TO_RESULT;
-
- wrapped_args.func = (Tcl_ObjCmdProc *) clientData;
- wrapped_args.interp = interp;
- wrapped_args.objc = objc;
- wrapped_args.objv = objv;
- wrapped_args.val = TCL_OK;
-
- if (!catch_errors (wrapped_call, &wrapped_args, "", RETURN_MASK_ALL))
- {
-
- wrapped_args.val = TCL_ERROR; /* Flag an error for TCL */
-
- /* Make sure the timer interrupts are turned off. */
- gdbtk_stop_timer ();
-
- gdb_flush (gdb_stderr); /* Flush error output */
- gdb_flush (gdb_stdout); /* Sometimes error output comes here as well */
-
- /* If we errored out here, and the results were going to the
- console, then gdbtk_fputs will have gathered the result into the
- result_ptr. We also need to echo them out to the console here */
-
- gdb_flush (gdb_stderr); /* Flush error output */
- gdb_flush (gdb_stdout); /* Sometimes error output comes here as well */
-
- /* In case of an error, we may need to force the GUI into idle
- mode because gdbtk_call_command may have bombed out while in
- the command routine. */
-
- running_now = 0;
- Tcl_Eval (interp, "gdbtk_tcl_idle");
-
- }
- else
- {
- /* If the wrapped call returned an error directly, then we don't
- want to reset the result. */
- wrapped_returned_error = wrapped_args.val == TCL_ERROR;
- }
-
- /* do not suppress any errors -- a remote target could have errored */
- load_in_progress = 0;
-
- /*
- * Now copy the result over to the true Tcl result. If
- * GDBTK_TO_RESULT flag bit is set, this just copies a null object
- * over to the Tcl result, which is fine because we should reset the
- * result in this case anyway. If the wrapped command returned an
- * error, then we assume that the result is already set correctly.
- */
- if ((result_ptr->flags & GDBTK_IN_TCL_RESULT) || wrapped_returned_error)
- {
- Tcl_DecrRefCount (result_ptr->obj_ptr);
- }
- else
- {
- Tcl_SetObjResult (interp, result_ptr->obj_ptr);
- }
-
- result_ptr = old_result_ptr;
-
-#ifdef _WIN32
- close_bfds ();
-#endif
-
- return wrapped_args.val;
-}
-
-/*
- * This is the wrapper that is passed to catch_errors.
- */
-
-static int
-wrapped_call (PTR opaque_args)
-{
- struct wrapped_call_args *args = (struct wrapped_call_args *) opaque_args;
- args->val = (*args->func) (args->func, args->interp, args->objc, args->objv);
- return 1;
-}
-
-
-/*
- * This section contains the commands that control execution.
- */
-
-/* This implements the tcl command gdb_clear_file.
-
-* Prepare to accept a new executable file. This is called when we
-* want to clear away everything we know about the old file, without
-* asking the user. The Tcl code will have already asked the user if
-* necessary. After this is called, we should be able to run the
-* `file' command without getting any questions.
-*
-* Arguments:
-* None
-* Tcl Result:
-* None
-*/
-
-static int
-gdb_clear_file (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- if (objc != 1)
- {
- Tcl_WrongNumArgs (interp, 1, objv, NULL);
- return TCL_ERROR;
- }
-
- if (! ptid_equal (inferior_ptid, null_ptid) && target_has_execution)
- {
- if (attach_flag)
- target_detach (NULL, 0);
- else
- target_kill ();
- }
-
- if (target_has_execution)
- pop_target ();
-
- delete_command (NULL, 0);
- exec_file_clear (0);
- symbol_file_clear (0);
-
- return TCL_OK;
-}
-
-/* This implements the tcl command gdb_confirm_quit
- * Ask the user to confirm an exit request.
- *
- * Arguments:
- * None
- * Tcl Result:
- * A boolean, 1 if the user answered yes, 0 if no.
- */
-
-static int
-gdb_confirm_quit (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- int ret;
-
- if (objc != 1)
- {
- Tcl_WrongNumArgs (interp, 1, objv, NULL);
- return TCL_ERROR;
- }
-
- ret = quit_confirm ();
- Tcl_SetBooleanObj (result_ptr->obj_ptr, ret);
- return TCL_OK;
-}
-
-/* This implements the tcl command gdb_force_quit
- * Quit without asking for confirmation.
- *
- * Arguments:
- * None
- * Tcl Result:
- * None
- */
-
-static int
-gdb_force_quit (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- if (objc != 1)
- {
- Tcl_WrongNumArgs (interp, 1, objv, NULL);
- return TCL_ERROR;
- }
-
- quit_force ((char *) NULL, 1);
- return TCL_OK;
-}
-
-/* Pressing the stop button on the source window should attempt to
- * stop the target. If, after some short time, this fails, a dialog
- * should appear allowing the user to detach.
- *
- * The global GDBTK_FORCE_DETACH is set when we wish to detach
- * from a target. This value is returned by ui_loop_hook (x_event),
- * indicating to callers that they should detach.
- *
- * Read the comments before x_event to find out how we (try) to keep
- * gdbtk alive while some other event loop has stolen control from us.
- */
-
-/*
- * This command implements the tcl command gdb_stop, which
- * is used to either stop the target or detach.
- * Note that it is assumed that a simulator or native target
- * can ALWAYS be stopped. Doing a "detach" on them has no effect.
- *
- * Arguments:
- * None or "detach"
- * Tcl Result:
- * None
- */
-
-static int
-gdb_stop (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- int force = 0;
- char *s;
-
- if (objc > 1)
- {
- s = Tcl_GetStringFromObj (objv[1], NULL);
- if (STREQ (s, "detach"))
- force = 1;
- }
-
- if (force)
- {
- /* Set the "forcibly detach from target" flag. x_event will
- return this value to callers when they should forcibly detach. */
- gdbtk_force_detach = 1;
- }
- else
- {
- if (target_stop != target_ignore)
- target_stop ();
- else
- quit_flag = 1; /* hope something sees this */
- }
-
- return TCL_OK;
-}
-
-
-/*
- * This section contains Tcl commands that are wrappers for invoking
- * the GDB command interpreter.
- */
-
-
-/* This implements the tcl command `gdb_eval'.
- * It uses the gdb evaluator to return the value of
- * an expression in the current language
- *
- * Tcl Arguments:
- * expression - the expression to evaluate.
- * format - optional format character. Valid chars are:
- * o - octal
- * x - hex
- * d - decimal
- * u - unsigned decimal
- * t - binary
- * f - float
- * a - address
- * c - char
- * Tcl Result:
- * The result of the evaluation.
- */
-
-static int
-gdb_eval (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- struct expression *expr;
- struct cleanup *old_chain = NULL;
- int format = 0;
- value_ptr val;
- struct ui_file *stb;
- long dummy;
- char *result;
-
- if (objc != 2 && objc != 3)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "expression [format]");
- return TCL_ERROR;
- }
-
- if (objc == 3)
- format = *(Tcl_GetStringFromObj (objv[2], NULL));
-
- expr = parse_expression (Tcl_GetStringFromObj (objv[1], NULL));
- old_chain = make_cleanup (free_current_contents, &expr);
- val = evaluate_expression (expr);
-
- /* "Print" the result of the expression evaluation. */
- stb = mem_fileopen ();
- make_cleanup_ui_file_delete (stb);
- val_print (VALUE_TYPE (val), VALUE_CONTENTS (val),
- VALUE_EMBEDDED_OFFSET (val), VALUE_ADDRESS (val),
- stb, format, 0, 0, 0);
- result = ui_file_xstrdup (stb, &dummy);
- Tcl_SetObjResult (interp, Tcl_NewStringObj (result, -1));
- xfree (result);
- result_ptr->flags |= GDBTK_IN_TCL_RESULT;
-
- do_cleanups (old_chain);
- return TCL_OK;
-}
-
-/* This implements the tcl command "gdb_cmd".
-
-* It sends its argument to the GDB command scanner for execution.
-* This command will never cause the update, idle and busy hooks to be called
-* within the GUI.
-*
-* Tcl Arguments:
-* command - The GDB command to execute
-* from_tty - 1 indicates this comes to the console.
-* Pass this to the gdb command.
-* Tcl Result:
-* The output from the gdb command (except for the "load" & "while"
-* which dump their output to the console.
-*/
-
-static int
-gdb_cmd (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- int from_tty = 0;
-
- if (objc < 2 || objc > 3)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "command ?from_tty?");
- return TCL_ERROR;
- }
-
- if (objc == 3)
- {
- if (Tcl_GetBooleanFromObj (NULL, objv[2], &from_tty) != TCL_OK)
- {
- gdbtk_set_result (interp, "from_tty must be a boolean.");
- return TCL_ERROR;
- }
- }
-
- if (running_now || load_in_progress)
- return TCL_OK;
-
- No_Update = 1;
-
- /* for the load instruction (and possibly others later) we
- set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
- will not buffer all the data until the command is finished. */
-
- if ((strncmp ("load ", Tcl_GetStringFromObj (objv[1], NULL), 5) == 0))
- {
- result_ptr->flags &= ~GDBTK_TO_RESULT;
- load_in_progress = 1;
- }
-
- execute_command (Tcl_GetStringFromObj (objv[1], NULL), from_tty);
-
- if (load_in_progress)
- {
- load_in_progress = 0;
- result_ptr->flags |= GDBTK_TO_RESULT;
- }
-
- bpstat_do_actions (&stop_bpstat);
-
- return TCL_OK;
-}
-
-/*
- * This implements the tcl command "gdb_immediate"
- *
- * It does exactly the same thing as gdb_cmd, except NONE of its outut
- * is buffered. This will also ALWAYS cause the busy, update, and idle
- * hooks to be called, contrasted with gdb_cmd, which NEVER calls them.
- * It turns off the GDBTK_TO_RESULT flag, which diverts the result
- * to the console window.
- *
- * Tcl Arguments:
- * command - The GDB command to execute
- * from_tty - 1 to indicate this is from the console.
- * Tcl Result:
- * None.
- */
-
-static int
-gdb_immediate_command (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- int from_tty = 0;
-
- if (objc < 2 || objc > 3)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "command ?from_tty?");
- return TCL_ERROR;
- }
-
- if (objc == 3)
- {
- if (Tcl_GetBooleanFromObj (NULL, objv[2], &from_tty) != TCL_OK)
- {
- gdbtk_set_result (interp, "from_tty must be a boolean.");
- return TCL_ERROR;
- }
- }
-
- if (running_now || load_in_progress)
- return TCL_OK;
-
- No_Update = 0;
-
- result_ptr->flags &= ~GDBTK_TO_RESULT;
-
- execute_command (Tcl_GetStringFromObj (objv[1], NULL), from_tty);
-
- bpstat_do_actions (&stop_bpstat);
-
- result_ptr->flags |= GDBTK_TO_RESULT;
-
- return TCL_OK;
-}
-
-/* This implements the tcl command "gdb_prompt"
-
-* It returns the gdb interpreter's prompt.
-*
-* Tcl Arguments:
-* None.
-* Tcl Result:
-* The prompt.
-*/
-
-static int
-gdb_prompt_command (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- Tcl_SetStringObj (result_ptr->obj_ptr, get_prompt (), -1);
- return TCL_OK;
-}
-
-
-/*
- * This section contains general informational commands.
- */
-
-/* This implements the tcl command "gdb_target_has_execution"
-
-* Tells whether the target is executing.
-*
-* Tcl Arguments:
-* None
-* Tcl Result:
-* A boolean indicating whether the target is executing.
-*/
-
-static int
-gdb_target_has_execution_command (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- int result = 0;
-
- if (target_has_execution && ! ptid_equal (inferior_ptid, null_ptid))
- result = 1;
-
- Tcl_SetBooleanObj (result_ptr->obj_ptr, result);
- return TCL_OK;
-}
-
-/* This implements the tcl command "gdb_get_inferior_args"
-
-* Returns inferior command line arguments as a string
-*
-* Tcl Arguments:
-* None
-* Tcl Result:
-* A string containing the inferior command line arguments
-*/
-
-static int
-gdb_get_inferior_args (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- if (objc != 1)
- {
- Tcl_WrongNumArgs (interp, 1, objv, NULL);
- return TCL_ERROR;
- }
-
- Tcl_SetStringObj (result_ptr->obj_ptr, get_inferior_args (), -1);
- return TCL_OK;
-}
-
-/* This implements the tcl command "gdb_set_inferior_args"
-
-* Sets inferior command line arguments
-*
-* Tcl Arguments:
-* A string containing the inferior command line arguments
-* Tcl Result:
-* None
-*/
-
-static int
-gdb_set_inferior_args (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- char *args;
-
- if (objc != 2)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "argument");
- return TCL_ERROR;
- }
-
- args = Tcl_GetStringFromObj (objv[1], NULL);
-
- /* The xstrdup/xfree stuff is so that we maintain a coherent picture
- for gdb. I would expect the accessors to do this, but they
- don't. */
- args = xstrdup (args);
- args = set_inferior_args (args);
- xfree (args);
-
- return TCL_OK;
-}
-
-/* This implements the tcl command "gdb_load_info"
-
-* It returns information about the file about to be downloaded.
-*
-* Tcl Arguments:
-* filename: The file to open & get the info on.
-* Tcl Result:
-* A list consisting of the name and size of each section.
-*/
-
-static int
-gdb_load_info (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- bfd *loadfile_bfd;
- struct cleanup *old_cleanups;
- asection *s;
- Tcl_Obj *ob[2];
-
- char *filename = Tcl_GetStringFromObj (objv[1], NULL);
-
- loadfile_bfd = bfd_openr (filename, gnutarget);
- if (loadfile_bfd == NULL)
- {
- gdbtk_set_result (interp, "Open of %s failed", filename);
- return TCL_ERROR;
- }
- old_cleanups = make_cleanup_bfd_close (loadfile_bfd);
-
- if (!bfd_check_format (loadfile_bfd, bfd_object))
- {
- gdbtk_set_result (interp, "Bad Object File");
- return TCL_ERROR;
- }
-
- Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
-
- for (s = loadfile_bfd->sections; s; s = s->next)
- {
- if (s->flags & SEC_LOAD)
- {
- bfd_size_type size = bfd_get_section_size_before_reloc (s);
- if (size > 0)
- {
- ob[0] = Tcl_NewStringObj ((char *)
- bfd_get_section_name (loadfile_bfd, s),
- -1);
- ob[1] = Tcl_NewLongObj ((long) size);
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
- Tcl_NewListObj (2, ob));
- }
- }
- }
-
- do_cleanups (old_cleanups);
- return TCL_OK;
-}
-
-
-/* This implements the tcl command "gdb_get_line"
-
-* It returns the linenumber for a given linespec. It will take any spec
-* that can be passed to decode_line_1
-*
-* Tcl Arguments:
-* linespec - the line specification
-* Tcl Result:
-* The line number for that spec.
-*/
-static int
-gdb_get_line_command (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- struct symtabs_and_lines sals;
- char *args, **canonical;
-
- if (objc != 2)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "linespec");
- return TCL_ERROR;
- }
-
- args = Tcl_GetStringFromObj (objv[1], NULL);
- sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
- if (sals.nelts == 1)
- {
- Tcl_SetIntObj (result_ptr->obj_ptr, sals.sals[0].line);
- return TCL_OK;
- }
-
- Tcl_SetStringObj (result_ptr->obj_ptr, "N/A", -1);
- return TCL_OK;
-
-}
-
-/* This implements the tcl command "gdb_get_file"
-
-* It returns the file containing a given line spec.
-*
-* Tcl Arguments:
-* linespec - The linespec to look up
-* Tcl Result:
-* The file containing it.
-*/
-
-static int
-gdb_get_file_command (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- struct symtabs_and_lines sals;
- char *args, **canonical;
-
- if (objc != 2)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "linespec");
- return TCL_ERROR;
- }
-
- args = Tcl_GetStringFromObj (objv[1], NULL);
- sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
- if (sals.nelts == 1)
- {
- Tcl_SetStringObj (result_ptr->obj_ptr,
- sals.sals[0].symtab->filename, -1);
- return TCL_OK;
- }
-
- Tcl_SetStringObj (result_ptr->obj_ptr, "N/A", -1);
- return TCL_OK;
-}
-
-/* This implements the tcl command "gdb_get_function"
-
-* It finds the function containing the given line spec.
-*
-* Tcl Arguments:
-* linespec - The line specification
-* Tcl Result:
-* The function that contains it, or "N/A" if it is not in a function.
-*/
-static int
-gdb_get_function_command (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- char *function;
- struct symtabs_and_lines sals;
- char *args, **canonical;
-
- if (objc != 2)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "linespec");
- return TCL_ERROR;
- }
-
- args = Tcl_GetStringFromObj (objv[1], NULL);
- sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
- if (sals.nelts == 1)
- {
- resolve_sal_pc (&sals.sals[0]);
- function = pc_function_name (sals.sals[0].pc);
- Tcl_SetStringObj (result_ptr->obj_ptr, function, -1);
- return TCL_OK;
- }
-
- Tcl_SetStringObj (result_ptr->obj_ptr, "N/A", -1);
- return TCL_OK;
-}
-
-/* This implements the tcl command "gdb_find_file"
-
-* It searches the symbol tables to get the full pathname to a file.
-*
-* Tcl Arguments:
-* filename: the file name to search for.
-* Tcl Result:
-* The full path to the file, an empty string if the file was not
-* available or an error message if the file is not found in the symtab.
-*/
-
-static int
-gdb_find_file_command (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- struct symtab *st;
- char *filename, *fullname;
-
- if (objc != 2)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "filename");
- return TCL_ERROR;
- }
-
- filename = Tcl_GetStringFromObj (objv[1], NULL);
- st = lookup_symtab (filename);
-
- /* We should always get a symtab. */
- if (!st)
- {
- gdbtk_set_result (interp, "File not found in symtab (2)");
- return TCL_ERROR;
- }
-
- if (st->fullname == NULL)
- fullname = symtab_to_filename (st);
- else
- fullname = st->fullname;
-
- /* We may not be able to open the file (not available). */
- if (fullname == NULL)
- {
- Tcl_SetStringObj (result_ptr->obj_ptr, "", -1);
- return TCL_OK;
- }
-
- Tcl_SetStringObj (result_ptr->obj_ptr, fullname, -1);
-
- return TCL_OK;
-}
-
-/* This implements the tcl command "gdb_listfiles"
-
-* This lists all the files in the current executible.
-*
-* Note that this currently pulls in all sorts of filenames
-* that aren't really part of the executable. It would be
-* best if we could check each file to see if it actually
-* contains executable lines of code, but we can't do that
-* with psymtabs.
-*
-* Arguments:
-* ?pathname? - If provided, only files which match pathname
-* (up to strlen(pathname)) are included. THIS DOES NOT
-* CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
-* THE FULL PATHNAME!!!
-*
-* Tcl Result:
-* A list of all matching files.
-*/
-static int
-gdb_listfiles (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- struct objfile *objfile;
- struct partial_symtab *psymtab;
- struct symtab *symtab;
- char *lastfile, *pathname = NULL, **files;
- int files_size;
- int i, numfiles = 0, len = 0;
-
- files_size = 1000;
- files = (char **) xmalloc (sizeof (char *) * files_size);
-
- if (objc > 2)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "?pathname?");
- return TCL_ERROR;
- }
- else if (objc == 2)
- pathname = Tcl_GetStringFromObj (objv[1], &len);
-
- ALL_PSYMTABS (objfile, psymtab)
- {
- if (numfiles == files_size)
- {
- files_size = files_size * 2;
- files = (char **) xrealloc (files, sizeof (char *) * files_size);
- }
- if (psymtab->filename)
- {
- if (!len || !strncmp (pathname, psymtab->filename, len)
- || !strcmp (psymtab->filename, basename (psymtab->filename)))
- {
- files[numfiles++] = basename (psymtab->filename);
- }
- }
- }
-
- ALL_SYMTABS (objfile, symtab)
- {
- if (numfiles == files_size)
- {
- files_size = files_size * 2;
- files = (char **) xrealloc (files, sizeof (char *) * files_size);
- }
- if (symtab->filename && symtab->linetable && symtab->linetable->nitems)
- {
- if (!len || !strncmp (pathname, symtab->filename, len)
- || !strcmp (symtab->filename, basename (symtab->filename)))
- {
- files[numfiles++] = basename (symtab->filename);
- }
- }
- }
-
- qsort (files, numfiles, sizeof (char *), comp_files);
-
- lastfile = "";
-
- /* Discard the old result pointer, in case it has accumulated anything
- and set it to a new list object */
-
- Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
-
- for (i = 0; i < numfiles; i++)
- {
- if (strcmp (files[i], lastfile))
- Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
- Tcl_NewStringObj (files[i], -1));
- lastfile = files[i];
- }
-
- free (files);
- return TCL_OK;
-}
-
-static int
-comp_files (const void *file1, const void *file2)
-{
- return strcmp (*(char **) file1, *(char **) file2);
-}
-
-
-/* This implements the tcl command "gdb_search"
-
-
-* Tcl Arguments:
-* option - One of "functions", "variables" or "types"
-* regexp - The regular expression to look for.
-* Then, optionally:
-* -files fileList
-* -static 1/0
-* -filename 1/0
-* Tcl Result:
-* A list of all the matches found. Optionally, if -filename is set to 1,
-* then the output is a list of two element lists, with the symbol first,
-* and the file in which it is found second.
-*/
-
-static int
-gdb_search (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- struct symbol_search *ss = NULL;
- struct symbol_search *p;
- struct cleanup *old_chain = NULL;
- Tcl_Obj *CONST * switch_objv;
- int index, switch_objc, i, show_files = 0;
- namespace_enum space = 0;
- char *regexp;
- int static_only, nfiles;
- Tcl_Obj **file_list;
- char **files;
- static const char *search_options[] =
- {"functions", "variables", "types", (char *) NULL};
- static const char *switches[] =
- {"-files", "-filename", "-static", (char *) NULL};
- enum search_opts
- {
- SEARCH_FUNCTIONS, SEARCH_VARIABLES, SEARCH_TYPES
- };
- enum switches_opts
- {
- SWITCH_FILES, SWITCH_FILENAME, SWITCH_STATIC_ONLY
- };
-
- if (objc < 3)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "option regexp ?arg ...?");
- return TCL_ERROR;
- }
-
- if (Tcl_GetIndexFromObj (interp, objv[1], search_options, "option", 0,
- &index) != TCL_OK)
- {
- result_ptr->flags |= GDBTK_IN_TCL_RESULT;
- return TCL_ERROR;
- }
-
- /* Unfortunately, we cannot teach search_symbols to search on
- multiple regexps, so we have to do a two-tier search for
- any searches which choose to narrow the playing field. */
- switch ((enum search_opts) index)
- {
- case SEARCH_FUNCTIONS:
- space = FUNCTIONS_NAMESPACE;
- break;
- case SEARCH_VARIABLES:
- space = VARIABLES_NAMESPACE;
- break;
- case SEARCH_TYPES:
- space = TYPES_NAMESPACE;
- break;
- }
-
- regexp = Tcl_GetStringFromObj (objv[2], NULL);
- /* Process any switches that refine the search */
- switch_objc = objc - 3;
- switch_objv = objv + 3;
-
- static_only = 0;
- nfiles = 0;
- files = (char **) NULL;
- while (switch_objc > 0)
- {
- if (Tcl_GetIndexFromObj (interp, switch_objv[0], switches,
- "option", 0, &index) != TCL_OK)
- {
- result_ptr->flags |= GDBTK_IN_TCL_RESULT;
- return TCL_ERROR;
- }
-
- switch ((enum switches_opts) index)
- {
- case SWITCH_FILENAME:
- {
- if (switch_objc < 2)
- {
- Tcl_WrongNumArgs (interp, 3, objv,
- "?-files fileList -filename 1|0 -static 1|0?");
- result_ptr->flags |= GDBTK_IN_TCL_RESULT;
- return TCL_ERROR;
- }
- if (Tcl_GetBooleanFromObj (interp, switch_objv[1], &show_files)
- != TCL_OK)
- {
- result_ptr->flags |= GDBTK_IN_TCL_RESULT;
- return TCL_ERROR;
- }
- switch_objc--;
- switch_objv++;
- }
- break;
- case SWITCH_FILES:
- {
- int result;
- if (switch_objc < 2)
- {
- Tcl_WrongNumArgs (interp, 3, objv,
- "?-files fileList -filename 1|0 -static 1|0?");
- result_ptr->flags |= GDBTK_IN_TCL_RESULT;
- return TCL_ERROR;
- }
- result = Tcl_ListObjGetElements (interp, switch_objv[1],
- &nfiles, &file_list);
- if (result != TCL_OK)
- return result;
-
- files = (char **) xmalloc (nfiles * sizeof (char *));
- for (i = 0; i < nfiles; i++)
- files[i] = Tcl_GetStringFromObj (file_list[i], NULL);
- switch_objc--;
- switch_objv++;
- }
- break;
- case SWITCH_STATIC_ONLY:
- if (switch_objc < 2)
- {
- Tcl_WrongNumArgs (interp, 3, objv,
- "?-files fileList -filename 1|0 -static 1|0?");
- result_ptr->flags |= GDBTK_IN_TCL_RESULT;
- return TCL_ERROR;
- }
- if (Tcl_GetBooleanFromObj (interp, switch_objv[1], &static_only)
- != TCL_OK)
- {
- result_ptr->flags |= GDBTK_IN_TCL_RESULT;
- return TCL_ERROR;
- }
- switch_objc--;
- switch_objv++;
- }
- switch_objc--;
- switch_objv++;
- }
-
- search_symbols (regexp, space, nfiles, files, &ss);
- if (ss != NULL)
- old_chain = make_cleanup_free_search_symbols (ss);
-
- Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
-
- for (p = ss; p != NULL; p = p->next)
- {
- Tcl_Obj *elem;
-
- if (static_only && p->block != STATIC_BLOCK)
- continue;
-
- /* Strip off some C++ special symbols, like RTTI and global
- constructors/destructors. */
- if ((p->symbol != NULL && !STREQN (DEPRECATED_SYMBOL_NAME (p->symbol), "__tf", 4)
- && !STREQN (DEPRECATED_SYMBOL_NAME (p->symbol), "_GLOBAL_", 8))
- || p->msymbol != NULL)
- {
- elem = Tcl_NewListObj (0, NULL);
-
- if (p->msymbol == NULL)
- Tcl_ListObjAppendElement (interp, elem,
- Tcl_NewStringObj (SYMBOL_PRINT_NAME (p->symbol), -1));
- else
- Tcl_ListObjAppendElement (interp, elem,
- Tcl_NewStringObj (SYMBOL_PRINT_NAME (p->msymbol), -1));
-
- if (show_files)
- {
- if ((p->symtab != NULL) && (p->symtab->filename != NULL))
- {
- Tcl_ListObjAppendElement (interp, elem, Tcl_NewStringObj
- (p->symtab->filename, -1));
- }
- else
- {
- Tcl_ListObjAppendElement (interp, elem,
- Tcl_NewStringObj ("", 0));
- }
- }
-
- Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, elem);
- }
- }
-
- if (ss != NULL)
- do_cleanups (old_chain);
-
- return TCL_OK;
-}
-
-/* This implements the tcl command gdb_listfuncs
-
-* It lists all the functions defined in a given file
-*
-* Arguments:
-* file - the file to look in
-* Tcl Result:
-* A list of two element lists, the first element is
-* the symbol name, and the second is a boolean indicating
-* whether the symbol is demangled (1 for yes).
-*/
-
-static int
-gdb_listfuncs (clientData, interp, objc, objv)
- ClientData clientData;
- Tcl_Interp *interp;
- int objc;
- Tcl_Obj *CONST objv[];
-{
- struct symtab *symtab;
- struct blockvector *bv;
- struct block *b;
- struct symbol *sym;
- int i, j;
- Tcl_Obj *funcVals[2];
-
- if (objc != 2)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "file");
- return TCL_ERROR;
- }
-
- symtab = lookup_symtab (Tcl_GetStringFromObj (objv[1], NULL));
- if (!symtab)
- {
- gdbtk_set_result (interp, "No such file (%s)",
- Tcl_GetStringFromObj (objv[1], NULL));
- return TCL_ERROR;
- }
-
- if (mangled == NULL)
- {
- mangled = Tcl_NewBooleanObj (1);
- not_mangled = Tcl_NewBooleanObj (0);
- Tcl_IncrRefCount (mangled);
- Tcl_IncrRefCount (not_mangled);
- }
-
- Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
-
- bv = BLOCKVECTOR (symtab);
- for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
- {
- b = BLOCKVECTOR_BLOCK (bv, i);
- ALL_BLOCK_SYMBOLS (b, j, sym)
- {
- if (SYMBOL_CLASS (sym) == LOC_BLOCK)
- {
-
- char *name = SYMBOL_DEMANGLED_NAME (sym);
-
- if (name)
- {
- /* strip out "global constructors" and
- * "global destructors"
- * because we aren't interested in them. */
-
- if (strncmp (name, "global ", 7))
- {
- /* If the function is overloaded,
- * print out the functions
- * declaration, not just its name. */
-
- funcVals[0] = Tcl_NewStringObj (name, -1);
- funcVals[1] = mangled;
- }
- else
- continue;
-
- }
- else
- {
- funcVals[0] = Tcl_NewStringObj (DEPRECATED_SYMBOL_NAME (sym), -1);
- funcVals[1] = not_mangled;
- }
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
- Tcl_NewListObj (2, funcVals));
- }
- }
- }
- return TCL_OK;
-}
-
-/* This implements the TCL command `gdb_restore_fputs'
- It sets the fputs_unfiltered hook back to gdbtk_fputs.
- Its sole reason for being is that sometimes we move the
- fputs hook out of the way to specially trap output, and if
- we get an error which we weren't expecting, it won't get put
- back, so we run this at idle time as insurance.
-*/
-
-static int
-gdb_restore_fputs (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- gdbtk_disable_fputs = 0;
- return TCL_OK;
-}
-
-
-/* This implements the tcl command gdb_load_disassembly
- *
- * Arguments:
- * widget - the name of a text widget into which to load the data
- * source_with_assm - must be "source" or "nosource"
- * low_address - the CORE_ADDR from which to start disassembly
- * ?hi_address? - the CORE_ADDR to which to disassemble, defaults
- * to the end of the function containing low_address.
- * Tcl Result:
- * The text widget is loaded with the data, and a list is returned.
- * The first element of the list is a two element list containing the
- * real low & high elements, the rest is a mapping between line number
- * in the text widget, and either the source line number of that line,
- * if it is a source line, or the assembly address. You can distinguish
- * between the two, because the address will start with 0x...
- */
-
-static int
-gdb_load_disassembly (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- CORE_ADDR low, high, orig;
- struct disassembly_client_data client_data;
- int mixed_source_and_assembly, ret_val, i;
- char *arg_ptr;
- char *map_name;
- Tcl_WideInt waddr;
-
- if (objc != 6 && objc != 7)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "[source|nosource] map_arr index_prefix low_address ?hi_address");
- return TCL_ERROR;
- }
-
- client_data.widget = Tcl_GetStringFromObj (objv[1], NULL);
- if ( Tk_NameToWindow (interp, client_data.widget,
- Tk_MainWindow (interp)) == NULL)
- {
- gdbtk_set_result (interp, "Invalid widget name.");
- return TCL_ERROR;
- }
-
- if (!Tcl_GetCommandInfo (interp, client_data.widget, &client_data.cmd))
- {
- gdbtk_set_result (interp, "Can't get widget command info");
- return TCL_ERROR;
- }
-
- arg_ptr = Tcl_GetStringFromObj (objv[2], NULL);
- if (*arg_ptr == 's' && strcmp (arg_ptr, "source") == 0)
- mixed_source_and_assembly = 1;
- else if (*arg_ptr == 'n' && strcmp (arg_ptr, "nosource") == 0)
- mixed_source_and_assembly = 0;
- else
- {
- gdbtk_set_result (interp, "Second arg must be 'source' or 'nosource'");
- return TCL_ERROR;
- }
-
- /* As we populate the text widget, we will also create an array in the
- caller's scope. The name is given by objv[3].
- Each source line gets an entry or the form:
- array($prefix,srcline=$src_line_no) = $widget_line_no
-
- Each assembly line gets two entries of the form:
- array($prefix,pc=$pc) = $widget_line_no
- array($prefix,line=$widget_line_no) = $src_line_no
-
- Where prefix is objv[4].
- */
-
- map_name = Tcl_GetStringFromObj (objv[3], NULL);
-
- if (*map_name != '\0')
- {
- char *prefix;
- int prefix_len;
-
- client_data.map_arr = "map_array";
- if (Tcl_UpVar (interp, "1", map_name, client_data.map_arr, 0) != TCL_OK)
- {
- gdbtk_set_result (interp, "Can't link map array.");
- return TCL_ERROR;
- }
-
- prefix = Tcl_GetStringFromObj (objv[4], &prefix_len);
-
- Tcl_DStringInit(&client_data.src_to_line_prefix);
- Tcl_DStringAppend (&client_data.src_to_line_prefix,
- prefix, prefix_len);
- Tcl_DStringAppend (&client_data.src_to_line_prefix, ",srcline=",
- sizeof (",srcline=") - 1);
-
- Tcl_DStringInit(&client_data.pc_to_line_prefix);
- Tcl_DStringAppend (&client_data.pc_to_line_prefix,
- prefix, prefix_len);
- Tcl_DStringAppend (&client_data.pc_to_line_prefix, ",pc=",
- sizeof (",pc=") - 1);
-
- Tcl_DStringInit(&client_data.line_to_pc_prefix);
- Tcl_DStringAppend (&client_data.line_to_pc_prefix,
- prefix, prefix_len);
- Tcl_DStringAppend (&client_data.line_to_pc_prefix, ",line=",
- sizeof (",line=") - 1);
-
- }
- else
- {
- client_data.map_arr = "";
- }
-
- /* Now parse the addresses */
- if (Tcl_GetWideIntFromObj (interp, objv[5], &waddr) != TCL_OK)
- return TCL_ERROR;
- low = waddr;
-
- orig = low;
-
- if (objc == 6)
- {
- if (find_pc_partial_function (low, NULL, &low, &high) == 0)
- error ("No function contains address 0x%s", core_addr_to_string (orig));
- }
- else
- {
- if (Tcl_GetWideIntFromObj (interp, objv[6], &waddr) != TCL_OK)
- return TCL_ERROR;
- high = waddr;
- }
-
- /* Setup the client_data structure, and call the driver function. */
-
- client_data.file_opened_p = 0;
- client_data.widget_line_no = 0;
- client_data.interp = interp;
- for (i = 0; i < 3; i++)
- {
- client_data.result_obj[i] = Tcl_NewObj();
- Tcl_IncrRefCount (client_data.result_obj[i]);
- }
-
- /* Fill up the constant parts of the argv structures */
- client_data.asm_argv[0] = client_data.widget;
- client_data.asm_argv[1] = "insert";
- client_data.asm_argv[2] = "end";
- client_data.asm_argv[3] = "-\t";
- client_data.asm_argv[4] = "break_rgn_tag";
- /* client_data.asm_argv[5] = address; */
- client_data.asm_argv[6] = "break_rgn_tag";
- /* client_data.asm_argv[7] = offset; */
- client_data.asm_argv[8] = "break_rgn_tag";
- client_data.asm_argv[9] = ":\t\t";
- client_data.asm_argv[10] = "source_tag";
- /* client_data.asm_argv[11] = code; */
- client_data.asm_argv[12] = "source_tag";
- client_data.asm_argv[13] = "\n";
-
- if (mixed_source_and_assembly)
- {
- client_data.source_argv[0] = client_data.widget;
- client_data.source_argv[1] = "insert";
- client_data.source_argv[2] = "end";
- /* client_data.source_argv[3] = line_number; */
- client_data.source_argv[4] = "";
- /* client_data.source_argv[5] = line; */
- client_data.source_argv[6] = "source_tag2";
- }
-
- ret_val = gdb_disassemble_driver (low, high, mixed_source_and_assembly,
- (ClientData) &client_data,
- gdbtk_load_source, gdbtk_load_asm);
-
- /* Now clean up the opened file, and the Tcl data structures */
-
- if (client_data.file_opened_p == 1)
- fclose(client_data.fp);
-
- if (*client_data.map_arr != '\0')
- {
- Tcl_DStringFree(&client_data.src_to_line_prefix);
- Tcl_DStringFree(&client_data.pc_to_line_prefix);
- Tcl_DStringFree(&client_data.line_to_pc_prefix);
- }
-
- for (i = 0; i < 3; i++)
- {
- Tcl_DecrRefCount (client_data.result_obj[i]);
- }
-
- /* Finally, if we were successful, stick the low & high addresses
- into the Tcl result. */
-
- if (ret_val == TCL_OK)
- {
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
- Tcl_NewStringObj (core_addr_to_string (low), -1));
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
- Tcl_NewStringObj (core_addr_to_string (high), -1));
- }
- return ret_val;
-}
-
-static void
-gdbtk_load_source (ClientData clientData, struct symtab *symtab,
- int start_line, int end_line)
-{
- struct disassembly_client_data *client_data =
- (struct disassembly_client_data *) clientData;
- char *buffer;
- int index_len;
-
- index_len = Tcl_DStringLength (&client_data->src_to_line_prefix);
-
- if (client_data->file_opened_p == 1)
- {
- const char **text_argv;
- char line[10000], line_number[18];
- int found_carriage_return = 1;
-
- /* First do some sanity checks on the requested lines */
-
- if (start_line < 1
- || end_line < start_line || end_line > symtab->nlines)
- {
- return;
- }
-
- line_number[0] = '\t';
- line[0] = '\t';
-
- text_argv = client_data->source_argv;
-
- text_argv[3] = line_number;
- text_argv[5] = line;
-
- if (fseek (client_data->fp, symtab->line_charpos[start_line - 1],
- SEEK_SET) < 0)
- {
- fclose(client_data->fp);
- client_data->file_opened_p = -1;
- return;
- }
-
- for (; start_line < end_line; start_line++)
- {
- if (!fgets (line + 1, 9980, client_data->fp))
- {
- fclose(client_data->fp);
- client_data->file_opened_p = -1;
- return;
- }
-
- client_data->widget_line_no++;
-
- sprintf (line_number + 1, "%d", start_line);
-
- if (found_carriage_return)
- {
- char *p = strrchr(line, '\0') - 2;
- if (*p == '\r')
- {
- *p = '\n';
- *(p + 1) = '\0';
- }
- else
- found_carriage_return = 0;
- }
-
- /* Run the command, then add an entry to the map array in
- the caller's scope, if requested. */
-
- client_data->cmd.proc (client_data->cmd.clientData,
- client_data->interp, 7, text_argv);
-
- if (*client_data->map_arr != '\0')
- {
-
- Tcl_DStringAppend (&client_data->src_to_line_prefix,
- line_number + 1, -1);
-
- /* FIXME: Convert to Tcl_SetVar2Ex when we move to 8.2. This
- will allow us avoid converting widget_line_no into a string. */
-
- xasprintf (&buffer, "%d", client_data->widget_line_no);
-
- Tcl_SetVar2 (client_data->interp, client_data->map_arr,
- Tcl_DStringValue (&client_data->src_to_line_prefix),
- buffer, 0);
- free(buffer);
-
- Tcl_DStringSetLength (&client_data->src_to_line_prefix, index_len);
- }
- }
-
- }
- else if (!client_data->file_opened_p)
- {
- int fdes;
- /* The file is not yet open, try to open it, then print the
- first line. If we fail, set FILE_OPEN_P to -1. */
-
- fdes = open_source_file (symtab);
- if (fdes < 0)
- {
- client_data->file_opened_p = -1;
- }
- else
- {
- /* FIXME: Convert to a Tcl File Channel and read from there.
- This will allow us to get the line endings and conversion
- to UTF8 right automatically when we move to 8.2.
- Need a Cygwin call to convert a file descriptor to the native
- Windows handler to do this. */
-
- client_data->file_opened_p = 1;
- client_data->fp = fdopen (fdes, FOPEN_RB);
- clearerr (client_data->fp);
-
- if (symtab->line_charpos == 0)
- find_source_lines (symtab, fdes);
-
- /* We are called with an actual load request, so call ourselves
- to load the first line. */
-
- gdbtk_load_source (clientData, symtab, start_line, end_line);
- }
- }
- else
- {
- /* If we couldn't open the file, or got some prior error, just exit. */
- return;
- }
-}
-
-
-static CORE_ADDR
-gdbtk_load_asm (ClientData clientData, CORE_ADDR pc,
- struct disassemble_info *di)
-{
- struct disassembly_client_data * client_data
- = (struct disassembly_client_data *) clientData;
- const char **text_argv;
- int i, pc_to_line_len, line_to_pc_len;
- gdbtk_result new_result;
- int insn;
- struct cleanup *old_chain = NULL;
-
- pc_to_line_len = Tcl_DStringLength (&client_data->pc_to_line_prefix);
- line_to_pc_len = Tcl_DStringLength (&client_data->line_to_pc_prefix);
-
- text_argv = client_data->asm_argv;
-
- /* Preserve the current Tcl result object, print out what we need, and then
- suck it out of the result, and replace... */
-
- old_chain = make_cleanup (gdbtk_restore_result_ptr, (void *) result_ptr);
- result_ptr = &new_result;
- result_ptr->obj_ptr = client_data->result_obj[0];
- result_ptr->flags = GDBTK_TO_RESULT;
-
- /* Null out the three return objects we will use. */
-
- for (i = 0; i < 3; i++)
- Tcl_SetObjLength (client_data->result_obj[i], 0);
-
- print_address_numeric (pc, 1, gdb_stdout);
- gdb_flush (gdb_stdout);
-
- result_ptr->obj_ptr = client_data->result_obj[1];
- print_address_symbolic (pc, gdb_stdout, 1, "\t");
- gdb_flush (gdb_stdout);
-
- result_ptr->obj_ptr = client_data->result_obj[2];
- insn = TARGET_PRINT_INSN (pc, di);
- gdb_flush (gdb_stdout);
-
- client_data->widget_line_no++;
-
- text_argv[5] = Tcl_GetStringFromObj (client_data->result_obj[0], NULL);
- text_argv[7] = Tcl_GetStringFromObj (client_data->result_obj[1], NULL);
- text_argv[11] = Tcl_GetStringFromObj (client_data->result_obj[2], NULL);
-
- client_data->cmd.proc (client_data->cmd.clientData,
- client_data->interp, 14, text_argv);
-
- if (*client_data->map_arr != '\0')
- {
- char *buffer;
-
- /* Run the command, then add an entry to the map array in
- the caller's scope. */
-
- Tcl_DStringAppend (&client_data->pc_to_line_prefix, core_addr_to_string (pc), -1);
-
- /* FIXME: Convert to Tcl_SetVar2Ex when we move to 8.2. This
- will allow us avoid converting widget_line_no into a string. */
-
- xasprintf (&buffer, "%d", client_data->widget_line_no);
-
- Tcl_SetVar2 (client_data->interp, client_data->map_arr,
- Tcl_DStringValue (&client_data->pc_to_line_prefix),
- buffer, 0);
-
- Tcl_DStringAppend (&client_data->line_to_pc_prefix, buffer, -1);
-
-
- Tcl_SetVar2 (client_data->interp, client_data->map_arr,
- Tcl_DStringValue (&client_data->line_to_pc_prefix),
- core_addr_to_string (pc), 0);
-
- /* Restore the prefixes to their initial state. */
-
- Tcl_DStringSetLength (&client_data->pc_to_line_prefix, pc_to_line_len);
- Tcl_DStringSetLength (&client_data->line_to_pc_prefix, line_to_pc_len);
-
- xfree (buffer);
- }
-
- do_cleanups (old_chain);
-
- return pc + insn;
-}
-
-static int
-gdb_disassemble_driver (CORE_ADDR low, CORE_ADDR high,
- int mixed_source_and_assembly,
- ClientData clientData,
- void (*print_source_fn) (ClientData, struct symtab *, int, int),
- CORE_ADDR (*print_asm_fn) (ClientData, CORE_ADDR, struct disassemble_info *))
-{
- CORE_ADDR pc;
- static disassemble_info di;
- static int di_initialized;
-
- if (! di_initialized)
- {
- INIT_DISASSEMBLE_INFO_NO_ARCH (di, gdb_stdout,
- (fprintf_ftype) fprintf_unfiltered);
- di.flavour = bfd_target_unknown_flavour;
- /* NOTE: cagney/2003-04: This all goes away, along with this
- function, when insight starts using the "disasm.h"
- disassembler. */
- di.memory_error_func = deprecated_tm_print_insn_info.memory_error_func;
- di.print_address_func = deprecated_tm_print_insn_info.print_address_func;
- di_initialized = 1;
- }
-
- di.mach = deprecated_tm_print_insn_info.mach;
- if (TARGET_BYTE_ORDER == BFD_ENDIAN_BIG)
- di.endian = BFD_ENDIAN_BIG;
- else
- di.endian = BFD_ENDIAN_LITTLE;
-
- /* Set the architecture for multi-arch configurations. */
- if (TARGET_ARCHITECTURE != NULL)
- di.mach = TARGET_ARCHITECTURE->mach;
-
- /* If disassemble_from_exec == -1, then we use the following heuristic to
- determine whether or not to do disassembly from target memory or from the
- exec file:
-
- If we're debugging a local process, read target memory, instead of the
- exec file. This makes disassembly of functions in shared libs work
- correctly. Also, read target memory if we are debugging native threads.
-
- Else, we're debugging a remote process, and should disassemble from the
- exec file for speed. However, this is no good if the target modifies its
- code (for relocation, or whatever).
-
- As an aside, it is fairly bogus that there is not a better way to
- determine where to disassemble from. There should be a target vector
- entry for this or something.
-
- */
-
- if (disassemble_from_exec == -1)
- {
- if (strcmp (target_shortname, "child") == 0
- || strcmp (target_shortname, "procfs") == 0
- || strcmp (target_shortname, "vxprocess") == 0
- || strstr (target_shortname, "thread") != NULL)
- /* It's a child process, read inferior mem */
- disassemble_from_exec = 0;
- else
- /* It's remote, read the exec file */
- disassemble_from_exec = 1;
- }
-
- if (disassemble_from_exec)
- di.read_memory_func = gdbtk_dis_asm_read_memory;
- else
- di.read_memory_func = deprecated_tm_print_insn_info.read_memory_func;
-
- /* If just doing straight assembly, all we need to do is disassemble
- everything between low and high. If doing mixed source/assembly, we've
- got a totally different path to follow. */
-
- if (mixed_source_and_assembly)
- { /* Come here for mixed source/assembly */
- /* The idea here is to present a source-O-centric view of a function to
- the user. This means that things are presented in source order, with
- (possibly) out of order assembly immediately following. */
- struct symtab *symtab;
- struct linetable_entry *le;
- int nlines;
- int newlines;
- struct my_line_entry *mle;
- struct symtab_and_line sal;
- int i;
- int out_of_order;
- int next_line;
-
- /* Assume symtab is valid for whole PC range */
- symtab = find_pc_symtab (low);
-
- if (!symtab || !symtab->linetable)
- goto assembly_only;
-
- /* First, convert the linetable to a bunch of my_line_entry's. */
-
- le = symtab->linetable->item;
- nlines = symtab->linetable->nitems;
-
- if (nlines <= 0)
- goto assembly_only;
-
- mle = (struct my_line_entry *) alloca (nlines *
- sizeof (struct my_line_entry));
-
- out_of_order = 0;
-
- /* Copy linetable entries for this function into our data structure,
- creating end_pc's and setting out_of_order as appropriate. */
-
- /* First, skip all the preceding functions. */
-
- for (i = 0; i < nlines - 1 && le[i].pc < low; i++) ;
-
- /* Now, copy all entries before the end of this function. */
-
- newlines = 0;
- for (; i < nlines - 1 && le[i].pc < high; i++)
- {
- if (le[i].line == le[i + 1].line
- && le[i].pc == le[i + 1].pc)
- continue; /* Ignore duplicates */
-
- /* Skip any end-of-function markers. */
- if (le[i].line == 0)
- continue;
-
- mle[newlines].line = le[i].line;
- if (le[i].line > le[i + 1].line)
- out_of_order = 1;
- mle[newlines].start_pc = le[i].pc;
- mle[newlines].end_pc = le[i + 1].pc;
- newlines++;
- }
-
- /* If we're on the last line, and it's part of the function, then we
- need to get the end pc in a special way. */
-
- if (i == nlines - 1
- && le[i].pc < high)
- {
- mle[newlines].line = le[i].line;
- mle[newlines].start_pc = le[i].pc;
- sal = find_pc_line (le[i].pc, 0);
- mle[newlines].end_pc = sal.end;
- newlines++;
- }
-
- /* Now, sort mle by line #s (and, then by addresses within lines). */
-
- if (out_of_order)
- qsort (mle, newlines, sizeof (struct my_line_entry), compare_lines);
-
- /* Now, for each line entry, emit the specified lines (unless they have
- been emitted before), followed by the assembly code for that line. */
-
- next_line = 0; /* Force out first line */
- for (i = 0; i < newlines; i++)
- {
- /* Print out everything from next_line to the current line. */
-
- if (mle[i].line >= next_line)
- {
- if (next_line != 0)
- print_source_fn (clientData, symtab, next_line,
- mle[i].line + 1);
- else
- print_source_fn (clientData, symtab, mle[i].line,
- mle[i].line + 1);
-
- next_line = mle[i].line + 1;
- }
-
- for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
- {
- QUIT;
- pc = print_asm_fn (clientData, pc, &di);
- }
- }
- }
- else
- {
- assembly_only:
- for (pc = low; pc < high; )
- {
- QUIT;
- pc = print_asm_fn (clientData, pc, &di);
- }
- }
-
- return TCL_OK;
-}
-
-/* This is the memory_read_func for gdb_disassemble_driver when we are
- disassembling from the exec file. */
-
-static int
-gdbtk_dis_asm_read_memory (bfd_vma memaddr, bfd_byte *myaddr,
- unsigned int len, disassemble_info *info)
-{
- extern struct target_ops exec_ops;
- int res;
-
- errno = 0;
- res = xfer_memory (memaddr, myaddr, len, 0, 0, &exec_ops);
-
- if (res == len)
- return 0;
- else if (errno == 0)
- return EIO;
- else
- return errno;
-}
-
-/* This will be passed to qsort to sort the results of the disassembly */
-
-static int
-compare_lines (const PTR mle1p, const PTR mle2p)
-{
- struct my_line_entry *mle1, *mle2;
- int val;
-
- mle1 = (struct my_line_entry *) mle1p;
- mle2 = (struct my_line_entry *) mle2p;
-
- val = mle1->line - mle2->line;
-
- if (val != 0)
- return val;
-
- return mle1->start_pc - mle2->start_pc;
-}
-
-/* This implements the TCL command `gdb_loc',
-
-* Arguments:
-* ?symbol? The symbol or address to locate - defaults to pc
-* Tcl Return:
-* a list consisting of the following:
-* basename, function name, filename, line number, address, current pc
-*/
-
-static int
-gdb_loc (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
-{
- char *filename;
- struct symtab_and_line sal;
- char *fname;
- CORE_ADDR pc;
-
- if (objc == 1)
- {
- if (deprecated_selected_frame
- && (get_frame_pc (deprecated_selected_frame) != read_pc ()))
- {
- /* Note - this next line is not correct on all architectures.
- For a graphical debugger we really want to highlight the
- assembly line that called the next function on the stack.
- Many architectures have the next instruction saved as the
- pc on the stack, so what happens is the next instruction
- is highlighted. FIXME */
- pc = get_frame_pc (deprecated_selected_frame);
- find_frame_sal (deprecated_selected_frame, &sal);
- }
- else
- {
- pc = read_pc ();
- sal = find_pc_line (pc, 0);
- }
- }
- else if (objc == 2)
- {
- struct symtabs_and_lines sals;
- int nelts;
-
- sals = decode_line_spec (Tcl_GetStringFromObj (objv[1], NULL), 1);
-
- nelts = sals.nelts;
- sal = sals.sals[0];
- free (sals.sals);
-
- if (sals.nelts != 1)
- {
- gdbtk_set_result (interp, "Ambiguous line spec", -1);
- return TCL_ERROR;
- }
- resolve_sal_pc (&sal);
- pc = sal.pc;
- }
- else
- {
- Tcl_WrongNumArgs (interp, 1, objv, "?symbol?");
- return TCL_ERROR;
- }
-
- if (sal.symtab)
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
- Tcl_NewStringObj (sal.symtab->filename, -1));
- else
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
- Tcl_NewStringObj ("", 0));
-
- fname = pc_function_name (pc);
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
- Tcl_NewStringObj (fname, -1));
-
- filename = symtab_to_filename (sal.symtab);
- if (filename == NULL)
- filename = "";
-
- /* file name */
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewStringObj (filename, -1));
- /* line number */
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (sal.line));
- /* PC in current frame */
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
- Tcl_NewStringObj (core_addr_to_string (pc), -1));
- /* Real PC */
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
- Tcl_NewStringObj (core_addr_to_string (stop_pc), -1));
- /* shared library */
-#ifdef PC_SOLIB
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
- Tcl_NewStringObj (PC_SOLIB (pc), -1));
-#else
- Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
- Tcl_NewStringObj ("", -1));
-#endif
- return TCL_OK;
-}
-
-/* This implements the TCL command gdb_entry_point. It returns the current
- entry point address. */
-
-static int
-gdb_entry_point (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- char *addrstr;
-
- /* If we have not yet loaded an exec file, then we have no
- entry point, so return an empty string.*/
- if ((int) current_target.to_stratum > (int) dummy_stratum)
- {
- addrstr = (char *)core_addr_to_string (entry_point_address ());
- Tcl_SetStringObj (result_ptr->obj_ptr, addrstr, -1);
- }
- else
- Tcl_SetStringObj (result_ptr->obj_ptr, "", -1);
-
- return TCL_OK;
-}
-
-/* Covert hex to binary. Stolen from remote.c,
- but added error handling */
-static int
-fromhex (int a)
-{
- if (a >= '0' && a <= '9')
- return a - '0';
- else if (a >= 'a' && a <= 'f')
- return a - 'a' + 10;
- else if (a >= 'A' && a <= 'F')
- return a - 'A' + 10;
-
- return -1;
-}
-
-static int
-hex2bin (const char *hex, char *bin, int count)
-{
- int i, m, n;
- int incr = 2;
-
-
- if (TARGET_BYTE_ORDER == BFD_ENDIAN_LITTLE)
- {
- /* need to read string in reverse */
- hex += count - 2;
- incr = -2;
- }
-
- for (i = 0; i < count; i += 2)
- {
- if (hex[0] == 0 || hex[1] == 0)
- {
- /* Hex string is short, or of uneven length.
- Return the count that has been converted so far. */
- return i;
- }
- m = fromhex (hex[0]);
- n = fromhex (hex[1]);
- if (m == -1 || n == -1)
- return -1;
- *bin++ = m * 16 + n;
- hex += incr;
- }
-
- return i;
-}
-
-/* This implements the Tcl command 'gdb_set_mem', which
- * sets some chunk of memory.
- *
- * Arguments:
- * gdb_set_mem addr hexstr len
- *
- * addr: address of data to set
- * hexstr: ascii string of data to set
- * len: number of bytes of data to set
- */
-static int
-gdb_set_mem (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- CORE_ADDR addr;
- char buf[128];
- char *hexstr;
- int len, size;
-
- if (objc != 4)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "addr hex_data len");
- return TCL_ERROR;
- }
-
- /* Address to write */
- addr = string_to_core_addr (Tcl_GetStringFromObj (objv[1], NULL));
-
- /* String value to write: it's in hex */
- hexstr = Tcl_GetStringFromObj (objv[2], NULL);
- if (hexstr == NULL)
- return TCL_ERROR;
-
- /* Length of buf */
- if (Tcl_GetIntFromObj (interp, objv[3], &len) != TCL_OK)
- return TCL_ERROR;
-
- /* Convert hexstr to binary and write */
- if (hexstr[0] == '0' && hexstr[1] == 'x')
- hexstr += 2;
- size = hex2bin (hexstr, buf, strlen (hexstr));
- if (size < 0)
- {
- /* Error in input */
- gdbtk_set_result (interp, "Invalid hexadecimal input: \"0x%s\"", hexstr);
- return TCL_ERROR;
- }
-
- target_write_memory (addr, buf, len);
- return TCL_OK;
-}
-
-/* This implements the Tcl command 'gdb_update_mem', which
- * updates a block of memory in the memory window
- *
- * Arguments:
- * gdb_update_mem data addr form size nbytes bpr aschar
- *
- * 1 data: variable that holds table's data
- * 2 addr: address of data to dump
- * 3 mform: a char indicating format
- * 4 size: size of each element; 1,2,4, or 8 bytes
- * 5 nbytes: the number of bytes to read
- * 6 bpr: bytes per row
- * 7 aschar: if present, an ASCII dump of the row is included. ASCHAR
- * used for unprintable characters.
- *
- * Return:
- * a list of three integers: {border_col_width data_col_width ascii_col_width}
- * which can be used to set the table's column widths. */
-
-static int
-gdb_update_mem (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- long dummy;
- char index[20];
- CORE_ADDR addr;
- int nbytes, rnum, bpr;
- int size, asize, i, j, bc;
- int max_ascii_len, max_val_len, max_label_len;
- char format, aschar;
- char *data, *tmp;
- char buff[128], *mbuf, *mptr, *cptr, *bptr;
- struct ui_file *stb;
- struct type *val_type;
- struct cleanup *old_chain;
-
- if (objc < 7 || objc > 8)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "data addr format size bytes bytes_per_row ?ascii_char?");
- return TCL_ERROR;
- }
-
- /* Get table data and link to a local variable */
- data = Tcl_GetStringFromObj (objv[1], NULL);
- if (data == NULL)
- {
- gdbtk_set_result (interp, "could not get data variable");
- return TCL_ERROR;
- }
-
- if (Tcl_UpVar (interp, "1", data, "data", 0) != TCL_OK)
- {
- gdbtk_set_result (interp, "could not link table data");
- return TCL_ERROR;
- }
-
- if (Tcl_GetIntFromObj (interp, objv[4], &size) != TCL_OK)
- return TCL_ERROR;
- else if (size <= 0)
- {
- gdbtk_set_result (interp, "Invalid size, must be > 0");
- return TCL_ERROR;
- }
-
- if (Tcl_GetIntFromObj (interp, objv[5], &nbytes) != TCL_OK)
- return TCL_ERROR;
- else if (nbytes <= 0)
- {
- gdbtk_set_result (interp, "Invalid number of bytes, must be > 0");
- return TCL_ERROR;
- }
-
- if (Tcl_GetIntFromObj (interp, objv[6], &bpr) != TCL_OK)
- return TCL_ERROR;
- else if (bpr <= 0)
- {
- gdbtk_set_result (interp, "Invalid bytes per row, must be > 0");
- return TCL_ERROR;
- }
-
- tmp = Tcl_GetStringFromObj (objv[2], NULL);
- if (tmp == NULL)
- {
- gdbtk_set_result (interp, "could not get address");
- return TCL_ERROR;
- }
- addr = string_to_core_addr (tmp);
-
- format = *(Tcl_GetStringFromObj (objv[3], NULL));
- mbuf = (char *) xmalloc (nbytes + 32);
- if (!mbuf)
- {
- gdbtk_set_result (interp, "Out of memory.");
- return TCL_ERROR;
- }
-
- memset (mbuf, 0, nbytes + 32);
- mptr = cptr = mbuf;
-
- rnum = 0;
- while (rnum < nbytes)
- {
- int error;
- int num = target_read_memory_partial (addr + rnum, mbuf + rnum,
- nbytes - rnum, &error);
- if (num <= 0)
- break;
- rnum += num;
- }
-
- if (objc == 8)
- aschar = *(Tcl_GetStringFromObj (objv[7], NULL));
- else
- aschar = 0;
-
- switch (size)
- {
- case 1:
- val_type = builtin_type_int8;
- asize = 'b';
- break;
- case 2:
- val_type = builtin_type_int16;
- asize = 'h';
- break;
- case 4:
- val_type = builtin_type_int32;
- asize = 'w';
- break;
- case 8:
- val_type = builtin_type_int64;
- asize = 'g';
- break;
- default:
- val_type = builtin_type_int8;
- asize = 'b';
- }
-
- bc = 0; /* count of bytes in a row */
- bptr = &buff[0]; /* pointer for ascii dump */
-
- /* Open a memory ui_file that we can use to print memory values */
- stb = mem_fileopen ();
- old_chain = make_cleanup_ui_file_delete (stb);
-
- /* A little macro to do column indices. As a rule, given the current
- byte, i, of a total nbytes and the bytes per row, bpr, and the size of
- each cell, size, the row and column will be given by:
-
- row = i/bpr
- col = (i%bpr)/size
- */
-#define INDEX(row,col) sprintf (index, "%d,%d",(row),(col))
-
- /* Fill in address labels */
- max_label_len = 0;
- for (i = 0; i < nbytes; i += bpr)
- {
- char s[130];
- sprintf (s, "%s", core_addr_to_string (addr + i));
- INDEX ((int) i/bpr, -1);
- Tcl_SetVar2 (interp, "data", index, s, 0);
-
- /* The tcl code in MemWin::update_addr used to track the size
- of each cell. I don't see how these could change for any given
- update, so we don't loop over all cells. We just note the first
- size. */
- if (max_label_len == 0)
- max_label_len = strlen (s);
- }
-
- /* Fill in memory */
- max_val_len = 0; /* Ditto the above comments about max_label_len */
- max_ascii_len = 0;
- for (i = 0; i < nbytes; i += size)
- {
- INDEX ((int) i/bpr, (int) (i%bpr)/size);
-
- if (i >= rnum)
- {
- /* Read fewer bytes than requested */
- tmp = "N/A";
-
- if (aschar)
- {
- for (j = 0; j < size; j++)
- *bptr++ = 'X';
- }
- }
- else
- {
- /* print memory to our uiout file and set the table's variable */
- ui_file_rewind (stb);
- print_scalar_formatted (mptr, val_type, format, asize, stb);
- tmp = ui_file_xstrdup (stb, &dummy);
-
- /* See comments above on max_*_len */
- if (max_val_len == 0)
- max_val_len = strlen (tmp);
-
- if (aschar)
- {
- for (j = 0; j < size; j++)
- {
- if (isprint (*cptr))
- *bptr++ = *cptr++;
- else
- {
- *bptr++ = aschar;
- cptr++;;
- }
- }
- }
- }
- Tcl_SetVar2 (interp, "data", index, tmp, 0);
-
- mptr += size;
- bc += size;
-
- if (aschar && (bc >= bpr))
- {
- /* end of row. Add it to the result and reset variables */
- *bptr = '\000';
- INDEX (i/bpr, bpr/size);
- Tcl_SetVar2 (interp, "data", index, buff, 0);
-
- /* See comments above on max_*_len */
- if (max_ascii_len == 0)
- max_ascii_len = strlen (buff);
-
- bc = 0;
- bptr = &buff[0];
- }
- }
-
- /* return max_*_len so that column widths can be set */
- Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (max_label_len + 1));
- Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (max_val_len + 1));
- Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (max_ascii_len + 1));
- do_cleanups (old_chain);
- xfree (mbuf);
- return TCL_OK;
-#undef INDEX
-}
-
-
-/* This implements the tcl command "gdb_loadfile"
- * It loads a c source file into a text widget.
- *
- * Tcl Arguments:
- * widget: the name of the text widget to fill
- * filename: the name of the file to load
- * linenumbers: A boolean indicating whether or not to display line numbers.
- * Tcl Result:
- *
- */
-
-/* In this routine, we will build up a "line table", i.e. a
- * table of bits showing which lines in the source file are executible.
- * LTABLE_SIZE is the number of bytes to allocate for the line table.
- *
- * Its size limits the maximum number of lines
- * in a file to 8 * LTABLE_SIZE. This memory is freed after
- * the file is loaded, so it is OK to make this very large.
- * Additional memory will be allocated if needed. */
-#define LTABLE_SIZE 20000
-static int
-gdb_loadfile (ClientData clientData, Tcl_Interp *interp, int objc,
- Tcl_Obj *CONST objv[])
-{
- char *file, *widget;
- int linenumbers, ln, lnum, ltable_size;
- FILE *fp;
- char *ltable;
- struct symtab *symtab;
- struct linetable_entry *le;
- long mtime = 0;
- struct stat st;
- char line[10000], line_num_buf[18];
- const char *text_argv[9];
- Tcl_CmdInfo text_cmd;
-
-
- if (objc != 4)
- {
- Tcl_WrongNumArgs(interp, 1, objv, "widget filename linenumbers");
- return TCL_ERROR;
- }
-
- widget = Tcl_GetStringFromObj (objv[1], NULL);
- if ( Tk_NameToWindow (interp, widget, Tk_MainWindow (interp)) == NULL)
- {
- return TCL_ERROR;
- }
-
- if (!Tcl_GetCommandInfo (interp, widget, &text_cmd))
- {
- gdbtk_set_result (interp, "Can't get widget command info");
- return TCL_ERROR;
- }
-
- file = Tcl_GetStringFromObj (objv[2], NULL);
- Tcl_GetBooleanFromObj (interp, objv[3], &linenumbers);
-
- symtab = lookup_symtab (file);
- if (!symtab)
- {
- gdbtk_set_result (interp, "File not found in symtab");
- return TCL_ERROR;
- }
-
- file = symtab_to_filename ( symtab );
- if ((fp = fopen ( file, "r" )) == NULL)
- {
- gdbtk_set_result (interp, "Can't open file for reading");
- return TCL_ERROR;
- }
-
- if (stat (file, &st) < 0)
- {
- catch_errors (perror_with_name_wrapper, "gdbtk: get time stamp", "",
- RETURN_MASK_ALL);
- return TCL_ERROR;
- }
-
- if (symtab && symtab->objfile && symtab->objfile->obfd)
- mtime = bfd_get_mtime(symtab->objfile->obfd);
- else if (exec_bfd)
- mtime = bfd_get_mtime(exec_bfd);
-
- if (mtime && mtime < st.st_mtime)
- {
- gdbtk_ignorable_warning("file_times",\
- "Source file is more recent than executable.\n");
- }
-
-
- /* Source linenumbers don't appear to be in order, and a sort is */
- /* too slow so the fastest solution is just to allocate a huge */
- /* array and set the array entry for each linenumber */
-
- ltable_size = LTABLE_SIZE;
- ltable = (char *)malloc (LTABLE_SIZE);
- if (ltable == NULL)
- {
- fclose (fp);
- gdbtk_set_result (interp, "Out of memory.");
- return TCL_ERROR;
- }
-
- memset (ltable, 0, LTABLE_SIZE);
-
- if (symtab->linetable && symtab->linetable->nitems)
- {
- le = symtab->linetable->item;
- for (ln = symtab->linetable->nitems ;ln > 0; ln--, le++)
- {
- lnum = le->line >> 3;
- if (lnum >= ltable_size)
- {
- char *new_ltable;
- new_ltable = (char *)realloc (ltable, ltable_size*2);
- memset (new_ltable + ltable_size, 0, ltable_size);
- ltable_size *= 2;
- if (new_ltable == NULL)
- {
- free (ltable);
- fclose (fp);
- gdbtk_set_result (interp, "Out of memory.");
- return TCL_ERROR;
- }
- ltable = new_ltable;
- }
- ltable[lnum] |= 1 << (le->line % 8);
- }
- }
-
- ln = 1;
-
- line[0] = '\t';
- text_argv[0] = widget;
- text_argv[1] = "insert";
- text_argv[2] = "end";
- text_argv[5] = line;
- text_argv[6] = "source_tag";
- text_argv[8] = NULL;
-
- if (linenumbers)
- {
- int found_carriage_return = 1;
-
- line_num_buf[1] = '\t';
-
- text_argv[3] = line_num_buf;
-
- while (fgets (line + 1, 9980, fp))
- {
- /* Look for DOS style \r\n endings, and if found,
- * strip off the \r. We assume (for the sake of
- * speed) that ALL lines in the file have DOS endings,
- * or none do.
- */
-
- if (found_carriage_return)
- {
- char *p = strrchr(line, '\0') - 2;
- if (*p == '\r')
- {
- *p = '\n';
- *(p + 1) = '\0';
- }
- else
- found_carriage_return = 0;
- }
-
- sprintf (line_num_buf+2, "%d", ln);
- if (ltable[ln >> 3] & (1 << (ln % 8)))
- {
- line_num_buf[0] = '-';
- text_argv[4] = "break_rgn_tag";
- }
- else
- {
- line_num_buf[0] = ' ';
- text_argv[4] = "";
- }
-
- text_cmd.proc(text_cmd.clientData, interp, 7, text_argv);
- ln++;
- }
- }
- else
- {
- int found_carriage_return = 1;
-
- while (fgets (line + 1, 9980, fp))
- {
- if (found_carriage_return)
- {
- char *p = strrchr(line, '\0') - 2;
- if (*p == '\r')
- {
- *p = '\n';
- *(p + 1) = '\0';
- }
- else
- found_carriage_return = 0;
- }
-
- if (ltable[ln >> 3] & (1 << (ln % 8)))
- {
- text_argv[3] = "- ";
- text_argv[4] = "break_rgn_tag";
- }
- else
- {
- text_argv[3] = " ";
- text_argv[4] = "";
- }
-
- text_cmd.proc(text_cmd.clientData, interp, 7, text_argv);
- ln++;
- }
- }
-
- free (ltable);
- fclose (fp);
- return TCL_OK;
-}
-
-/*
- * This section contains a bunch of miscellaneous utility commands
- */
-
-/* This implements the tcl command gdb_path_conv
-
-* On Windows, it canonicalizes the pathname,
-* On Unix, it is a no op.
-*
-* Arguments:
-* path
-* Tcl Result:
-* The canonicalized path.
-*/
-
-static int
-gdb_path_conv (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- if (objc != 2)
- {
- Tcl_WrongNumArgs (interp, 1, objv, NULL);
- return TCL_ERROR;
- }
-
-#ifdef __CYGWIN__
- {
- char pathname[256], *ptr;
-
- cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj (objv[1], NULL),
- pathname);
- for (ptr = pathname; *ptr; ptr++)
- {
- if (*ptr == '\\')
- *ptr = '/';
- }
- Tcl_SetStringObj (result_ptr->obj_ptr, pathname, -1);
- }
-#else
- Tcl_SetStringObj (result_ptr->obj_ptr, Tcl_GetStringFromObj (objv[1], NULL),
- -1);
-#endif
-
- return TCL_OK;
-}
-
-/*
- * This section has utility routines that are not Tcl commands.
- */
-
-static int
-perror_with_name_wrapper (PTR args)
-{
- perror_with_name (args);
- return 1;
-}
-
-/* Look for the function that contains PC and return the source
- (demangled) name for this function.
-
- If no symbol is found, it returns an empty string. In either
- case, memory is owned by gdb. Do not attempt to free it. */
-char *
-pc_function_name (CORE_ADDR pc)
-{
- struct symbol *sym;
- char *funcname = NULL;
-
- /* First lookup the address in the symbol table... */
- sym = find_pc_function (pc);
- if (sym != NULL)
- funcname = GDBTK_SYMBOL_SOURCE_NAME (sym);
- else
- {
- /* ... if that fails, look it up in the minimal symbols. */
- struct minimal_symbol *msym = NULL;
-
- msym = lookup_minimal_symbol_by_pc (pc);
- if (msym != NULL)
- funcname = GDBTK_SYMBOL_SOURCE_NAME (msym);
- }
-
- if (funcname == NULL)
- funcname = "";
-
- return funcname;
-}
-
-void
-gdbtk_set_result (Tcl_Interp *interp, const char *fmt,...)
-{
- va_list args;
- char *buf;
-
- va_start (args, fmt);
- xvasprintf (&buf, fmt, args);
- va_end (args);
- Tcl_SetObjResult (interp, Tcl_NewStringObj (buf, -1));
- xfree(buf);
-}
-
-
-/* This implements the tcl command 'gdb_incr_addr'.
- * It does address arithmetic and outputs a proper
- * hex string. This was originally implemented
- * when tcl did not support 64-bit values, but we keep
- * it because it saves us from having to call incr
- * followed by format to get the result in hex.
- * Also, it may be true in the future that CORE_ADDRs
- * will have their own ALU to deal properly with
- * architecture-specific address arithmetic.
- *
- * Tcl Arguments:
- * addr - CORE_ADDR
- * number - optional number to add to the address
- * default is 1.
- *
- * Tcl Result:
- * hex string containing the result of addr + number
- */
-
-static int
-gdb_incr_addr (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- CORE_ADDR address;
- int number = 1;
-
- if (objc != 2 && objc != 3)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "CORE_ADDR [number]");
- return TCL_ERROR;
- }
-
- address = string_to_core_addr (Tcl_GetStringFromObj (objv[1], NULL));
-
- if (objc == 3)
- {
- if (Tcl_GetIntFromObj (interp, objv[2], &number) != TCL_OK)
- return TCL_ERROR;
- }
-
- address += number;
-
- Tcl_SetStringObj (result_ptr->obj_ptr, (char *)core_addr_to_string (address), -1);
-
- return TCL_OK;
-}
-
-/* This implements the tcl command 'gdb_CAS_to_TAS'.
- * It takes a CORE_ADDR and outputs a string suitable
- * for displaying as the target address.
- *
- * Note that CORE_ADDRs are internal addresses which map
- * to target addresses in different ways depending on the
- * architecture. The target address string is a user-readable
- * string may be quite different than the CORE_ADDR. For example,
- * a CORE_ADDR of 0x02001234 might indicate a data address of
- * 0x1234 which this function might someday output as something
- * like "D:1234".
- *
- * Tcl Arguments:
- * address - CORE_ADDR
- *
- * Tcl Result:
- * string
- */
-
-static int
-gdb_CA_to_TAS (ClientData clientData, Tcl_Interp *interp,
- int objc, Tcl_Obj *CONST objv[])
-{
- CORE_ADDR address;
- Tcl_WideInt wide_addr;
-
- if (objc != 2)
- {
- Tcl_WrongNumArgs (interp, 1, objv, "CORE_ADDR");
- return TCL_ERROR;
- }
-
- /* Read address into a wideint, which is the largest tcl supports
- then convert to a CORE_ADDR */
- if (Tcl_GetWideIntFromObj (interp, objv[1], &wide_addr) != TCL_OK)
- return TCL_ERROR;
- address = wide_addr;
-
- /* This is not really correct. Using paddr_nz() will convert to hex and truncate
- to 32-bits when required but will otherwise not do what we really want. */
- Tcl_SetStringObj (result_ptr->obj_ptr, paddr_nz (address), -1);
-
- return TCL_OK;
-}