3544 lines
97 KiB
C
3544 lines
97 KiB
C
/* Tcl/Tk command definitions for gdbtk.
|
||
Copyright 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
|
||
|
||
Written by Stu Grossman <grossman@cygnus.com> 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 "symtab.h"
|
||
#include "inferior.h"
|
||
#include "command.h"
|
||
#include "bfd.h"
|
||
#include "symfile.h"
|
||
#include "objfiles.h"
|
||
#include "target.h"
|
||
#include "gdbcore.h"
|
||
#include "tracepoint.h"
|
||
#include "demangle.h"
|
||
|
||
#ifdef _WIN32
|
||
#include <winuser.h>
|
||
#endif
|
||
|
||
#include <sys/stat.h>
|
||
|
||
#include <tcl.h>
|
||
#include <tk.h>
|
||
#include <itcl.h>
|
||
#include <tix.h>
|
||
#include "guitcl.h"
|
||
#include "gdbtk.h"
|
||
|
||
#ifdef IDE
|
||
/* start-sanitize-ide */
|
||
#include "event.h"
|
||
#include "idetcl.h"
|
||
#include "ilutk.h"
|
||
/* end-sanitize-ide */
|
||
#endif
|
||
|
||
#ifdef ANSI_PROTOTYPES
|
||
#include <stdarg.h>
|
||
#else
|
||
#include <varargs.h>
|
||
#endif
|
||
#include <signal.h>
|
||
#include <fcntl.h>
|
||
#include <unistd.h>
|
||
#include <setjmp.h>
|
||
#include "top.h"
|
||
#include <sys/ioctl.h>
|
||
#include "gdb_string.h"
|
||
#include "dis-asm.h"
|
||
#include <stdio.h>
|
||
#include "gdbcmd.h"
|
||
|
||
#include "annotate.h"
|
||
#include <sys/time.h>
|
||
|
||
/* This structure filled in call_wrapper and passed to
|
||
the wrapped call function.
|
||
It stores the command pointer and arguments
|
||
run in the wrapper function. */
|
||
|
||
struct wrapped_call_args
|
||
{
|
||
Tcl_Interp *interp;
|
||
Tcl_ObjCmdProc *func;
|
||
int objc;
|
||
Tcl_Obj *CONST *objv;
|
||
int val;
|
||
};
|
||
|
||
/* 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 is used in the register fetching routines
|
||
*/
|
||
|
||
#ifndef REGISTER_CONVERTIBLE
|
||
#define REGISTER_CONVERTIBLE(x) (0 != 0)
|
||
#endif
|
||
|
||
#ifndef REGISTER_CONVERT_TO_VIRTUAL
|
||
#define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
|
||
#endif
|
||
|
||
#ifndef INVALID_FLOAT
|
||
#define INVALID_FLOAT(x, y) (0 != 0)
|
||
#endif
|
||
|
||
|
||
|
||
/* This Structure is used in gdb_disassemble.
|
||
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;
|
||
};
|
||
|
||
/* This contains the previous values of the registers, since the last call to
|
||
gdb_changed_register_list. */
|
||
|
||
static char old_regs[REGISTER_BYTES];
|
||
|
||
/* These two lookup tables are used to translate the type & disposition fields
|
||
of the breakpoint structure (respectively) into something gdbtk understands.
|
||
They are also used in gdbtk-hooks.c */
|
||
|
||
char *bptypes[] = {"breakpoint", "hardware breakpoint", "until",
|
||
"finish", "watchpoint", "hardware watchpoint",
|
||
"read watchpoint", "access watchpoint",
|
||
"longjmp", "longjmp resume", "step resume",
|
||
"through sigtramp", "watchpoint scope",
|
||
"call dummy" };
|
||
char *bpdisp[] = {"delete", "delstop", "disable", "donttouch"};
|
||
|
||
/*
|
||
* These are routines we need from breakpoint.c.
|
||
* at some point make these static in breakpoint.c and move GUI code there
|
||
*/
|
||
|
||
extern struct breakpoint *set_raw_breakpoint (struct symtab_and_line sal);
|
||
extern void set_breakpoint_count (int);
|
||
extern int breakpoint_count;
|
||
|
||
/* This variable determines where memory used for disassembly is read from.
|
||
* See note in gdbtk.h for details.
|
||
*/
|
||
int disassemble_from_exec = -1;
|
||
|
||
|
||
/*
|
||
* 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 PARAMS ((const PTR, const PTR));
|
||
static int comp_files PARAMS ((const void *, const void *));
|
||
static int call_wrapper PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_actions_command PARAMS ((ClientData, Tcl_Interp *, int,
|
||
Tcl_Obj *CONST objv[]));
|
||
static int gdb_changed_register_list PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_clear_file PARAMS ((ClientData, Tcl_Interp *interp, int, Tcl_Obj *CONST []));
|
||
static int gdb_cmd PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_confirm_quit PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_disassemble PARAMS ((ClientData, Tcl_Interp *, int,
|
||
Tcl_Obj *CONST []));
|
||
static int gdb_eval PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_fetch_registers PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_find_file_command PARAMS ((ClientData, Tcl_Interp *, int,
|
||
Tcl_Obj *CONST objv[]));
|
||
static int gdb_force_quit PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static struct symtab *full_lookup_symtab PARAMS ((char *file));
|
||
static int gdb_get_args_command PARAMS ((ClientData, Tcl_Interp *, int,
|
||
Tcl_Obj *CONST objv[]));
|
||
static int gdb_get_breakpoint_info PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_get_breakpoint_list PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_get_file_command PARAMS ((ClientData, Tcl_Interp *, int,
|
||
Tcl_Obj *CONST objv[]));
|
||
static int gdb_get_function_command PARAMS ((ClientData, Tcl_Interp *, int,
|
||
Tcl_Obj *CONST objv[]));
|
||
static int gdb_get_line_command PARAMS ((ClientData, Tcl_Interp *, int,
|
||
Tcl_Obj *CONST objv[]));
|
||
static int gdb_get_locals_command PARAMS ((ClientData, Tcl_Interp *, int,
|
||
Tcl_Obj *CONST objv[]));
|
||
static int gdb_get_mem PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_get_trace_frame_num PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
|
||
static int gdb_get_tracepoint_list PARAMS ((ClientData, Tcl_Interp *, int,
|
||
Tcl_Obj *CONST objv[]));
|
||
static int gdb_get_vars_command PARAMS ((ClientData, Tcl_Interp *, int,
|
||
Tcl_Obj *CONST objv[]));
|
||
static int gdb_immediate_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_listfiles PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_listfuncs PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_loadfile PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
|
||
static int gdb_load_info PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
|
||
static int gdb_loc PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_path_conv PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_prompt_command PARAMS ((ClientData, Tcl_Interp *, int,
|
||
Tcl_Obj *CONST objv[]));
|
||
static int gdb_regnames PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_search PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST
|
||
objv[]));
|
||
static int gdb_set_bp PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
|
||
static int gdb_set_bp_addr PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
|
||
static int gdb_find_bp_at_line PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
|
||
static int gdb_find_bp_at_addr PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
|
||
static int gdb_stop PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_target_has_execution_command PARAMS ((ClientData, Tcl_Interp *,
|
||
int,
|
||
Tcl_Obj *CONST []));
|
||
static int gdb_trace_status PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_tracepoint_exists_command PARAMS ((ClientData, Tcl_Interp *,
|
||
int,
|
||
Tcl_Obj *CONST objv[]));
|
||
static int gdb_get_tracepoint_info PARAMS ((ClientData, Tcl_Interp *, int,
|
||
Tcl_Obj *CONST objv[]));
|
||
static int gdbtk_dis_asm_read_memory PARAMS ((bfd_vma, bfd_byte *, int, disassemble_info *));
|
||
static int get_pc_register PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
static int gdb_stack PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
|
||
|
||
char * get_prompt PARAMS ((void));
|
||
static void get_register PARAMS ((int, void *));
|
||
static void get_register_name PARAMS ((int, void *));
|
||
static int map_arg_registers PARAMS ((int, Tcl_Obj *CONST [], void (*) (int, void *), void *));
|
||
static int perror_with_name_wrapper PARAMS ((char *args));
|
||
static void register_changed_p PARAMS ((int, void *));
|
||
void TclDebug PARAMS ((const char *fmt, ...));
|
||
static int wrapped_call (char *opaque_args);
|
||
static void get_frame_name PARAMS ((Tcl_Interp *interp, Tcl_Obj *list, struct frame_info *fi));
|
||
|
||
/* 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 (interp)
|
||
Tcl_Interp *interp;
|
||
{
|
||
Tcl_CreateObjCommand (interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_immediate", call_wrapper,
|
||
gdb_immediate_command, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_loc", call_wrapper, gdb_loc, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_path_conv", call_wrapper, gdb_path_conv, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_listfiles", call_wrapper, gdb_listfiles, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_listfuncs", call_wrapper, gdb_listfuncs,
|
||
NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_get_mem", call_wrapper, gdb_get_mem,
|
||
NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_stop", call_wrapper, gdb_stop, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_fetch_registers", call_wrapper,
|
||
gdb_fetch_registers, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_changed_register_list", call_wrapper,
|
||
gdb_changed_register_list, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_disassemble", call_wrapper,
|
||
gdb_disassemble, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_eval", call_wrapper, gdb_eval, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_get_breakpoint_list", call_wrapper,
|
||
gdb_get_breakpoint_list, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_get_breakpoint_info", call_wrapper,
|
||
gdb_get_breakpoint_info, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_clear_file", call_wrapper,
|
||
gdb_clear_file, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_confirm_quit", call_wrapper,
|
||
gdb_confirm_quit, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_force_quit", call_wrapper,
|
||
gdb_force_quit, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_target_has_execution",
|
||
call_wrapper,
|
||
gdb_target_has_execution_command, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_is_tracing",
|
||
call_wrapper, gdb_trace_status,
|
||
NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_load_info", call_wrapper, gdb_load_info, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_get_locals", call_wrapper, gdb_get_locals_command,
|
||
NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_get_args", call_wrapper, gdb_get_args_command,
|
||
NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_get_function", call_wrapper, gdb_get_function_command,
|
||
NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_get_line", call_wrapper, gdb_get_line_command,
|
||
NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_get_file", call_wrapper, gdb_get_file_command,
|
||
NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_tracepoint_exists",
|
||
call_wrapper, gdb_tracepoint_exists_command, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_get_tracepoint_info",
|
||
call_wrapper, gdb_get_tracepoint_info, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_actions",
|
||
call_wrapper, gdb_actions_command, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_prompt",
|
||
call_wrapper, gdb_prompt_command, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_find_file",
|
||
call_wrapper, gdb_find_file_command, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_get_tracepoint_list",
|
||
call_wrapper, gdb_get_tracepoint_list, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_pc_reg", call_wrapper, get_pc_register, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_loadfile", call_wrapper, gdb_loadfile, NULL);
|
||
Tcl_CreateObjCommand (gdbtk_interp, "gdb_search", call_wrapper,
|
||
gdb_search, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_set_bp", call_wrapper, gdb_set_bp, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_set_bp_addr", call_wrapper, gdb_set_bp_addr, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_find_bp_at_line", call_wrapper, gdb_find_bp_at_line, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_find_bp_at_addr", call_wrapper, gdb_find_bp_at_addr, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_get_trace_frame_num",
|
||
call_wrapper, gdb_get_trace_frame_num, NULL);
|
||
Tcl_CreateObjCommand (interp, "gdb_stack", call_wrapper, gdb_stack, NULL);
|
||
|
||
Tcl_LinkVar (interp, "gdb_selected_frame_level",
|
||
(char *) &selected_frame_level,
|
||
TCL_LINK_INT | TCL_LINK_READ_ONLY);
|
||
|
||
/* 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);
|
||
|
||
/* 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. */
|
||
|
||
static int
|
||
call_wrapper (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
struct wrapped_call_args wrapped_args;
|
||
gdbtk_result new_result, *old_result_ptr;
|
||
|
||
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");
|
||
|
||
}
|
||
|
||
/* 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 (result_ptr->flags & GDBTK_IN_TCL_RESULT)
|
||
{
|
||
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 (opaque_args)
|
||
char *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 is a convenience function to sprintf something(s) into a
|
||
* new element in a Tcl list object.
|
||
*/
|
||
|
||
static void
|
||
#ifdef ANSI_PROTOTYPES
|
||
sprintf_append_element_to_obj (Tcl_Obj *objp, char *format, ...)
|
||
#else
|
||
sprintf_append_element_to_obj (va_alist)
|
||
va_dcl
|
||
#endif
|
||
{
|
||
va_list args;
|
||
char buf[1024];
|
||
|
||
#ifdef ANSI_PROTOTYPES
|
||
va_start (args, format);
|
||
#else
|
||
Tcl_Obj *objp;
|
||
char *format;
|
||
|
||
va_start (args);
|
||
dsp = va_arg (args, Tcl_Obj *);
|
||
format = va_arg (args, char *);
|
||
#endif
|
||
|
||
vsprintf (buf, format, args);
|
||
|
||
Tcl_ListObjAppendElement (NULL, objp, Tcl_NewStringObj (buf, -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, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
if (objc != 1)
|
||
Tcl_SetStringObj (result_ptr->obj_ptr,
|
||
"Wrong number of args, none are allowed.", -1);
|
||
|
||
if (inferior_pid != 0 && target_has_execution)
|
||
{
|
||
if (attach_flag)
|
||
target_detach (NULL, 0);
|
||
else
|
||
target_kill ();
|
||
}
|
||
|
||
if (target_has_execution)
|
||
pop_target ();
|
||
|
||
symbol_file_command (NULL, 0);
|
||
|
||
/* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
|
||
clear it here. FIXME: This seems like an abstraction violation
|
||
somewhere. */
|
||
stop_pc = 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, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
int ret;
|
||
|
||
if (objc != 1)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "Wrong number of args, should be none.", -1);
|
||
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, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
if (objc != 1)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "Wrong number of args, should be none.", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
quit_force ((char *) NULL, 1);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/* This implements the tcl command gdb_stop
|
||
* It stops the target in a continuable fashion.
|
||
*
|
||
* Arguments:
|
||
* None
|
||
* Tcl Result:
|
||
* None
|
||
*/
|
||
|
||
static int
|
||
gdb_stop (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
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.
|
||
* Tcl Result:
|
||
* The result of the evaluation.
|
||
*/
|
||
|
||
static int
|
||
gdb_eval (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
struct expression *expr;
|
||
struct cleanup *old_chain=NULL;
|
||
value_ptr val;
|
||
|
||
if (objc != 2)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr,
|
||
"wrong # args, should be \"gdb_eval expression\"", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
expr = parse_expression (Tcl_GetStringFromObj (objv[1], NULL));
|
||
|
||
old_chain = make_cleanup ((make_cleanup_func) free_current_contents, &expr);
|
||
|
||
val = evaluate_expression (expr);
|
||
|
||
/*
|
||
* Print the result of the expression evaluation. This will go to
|
||
* eventually go to gdbtk_fputs, and from there be collected into
|
||
* the Tcl result.
|
||
*/
|
||
|
||
val_print (VALUE_TYPE (val), VALUE_CONTENTS (val),
|
||
VALUE_EMBEDDED_OFFSET(val), VALUE_ADDRESS (val),
|
||
gdb_stdout, 0, 0, 0, 0);
|
||
|
||
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
|
||
* 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, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
int from_tty = 0;
|
||
|
||
if (objc < 2)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (objc == 3)
|
||
{
|
||
if (Tcl_GetBooleanFromObj (NULL, objv[2], &from_tty) != TCL_OK) {
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "from_tty must be a boolean.",
|
||
-1);
|
||
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
|
||
* Tcl Result:
|
||
* None.
|
||
*/
|
||
|
||
static int
|
||
gdb_immediate_command (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
|
||
if (objc != 2)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
|
||
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), 1);
|
||
|
||
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, interp, objc, objv)
|
||
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, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
int result = 0;
|
||
|
||
if (target_has_execution && inferior_pid != 0)
|
||
result = 1;
|
||
|
||
Tcl_SetBooleanObj (result_ptr->obj_ptr, result);
|
||
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, interp, objc, objv)
|
||
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)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "Open failed", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
old_cleanups = make_cleanup ((make_cleanup_func) bfd_close, loadfile_bfd);
|
||
|
||
if (!bfd_check_format (loadfile_bfd, bfd_object))
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "Bad Object File", -1);
|
||
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;
|
||
}
|
||
|
||
|
||
/* gdb_get_locals -
|
||
* This and gdb_get_locals just call gdb_get_vars_command with the right
|
||
* value of clientData. We can't use the client data in the definition
|
||
* of the command, because the call wrapper uses this instead...
|
||
*/
|
||
|
||
static int
|
||
gdb_get_locals_command (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
|
||
return gdb_get_vars_command((ClientData) 0, interp, objc, objv);
|
||
|
||
}
|
||
|
||
static int
|
||
gdb_get_args_command (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
|
||
return gdb_get_vars_command((ClientData) 1, interp, objc, objv);
|
||
|
||
}
|
||
|
||
/* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
|
||
*
|
||
* This function sets the Tcl interpreter's result to a list of variable names
|
||
* depending on clientData. If clientData is one, the result is a list of
|
||
* arguments; zero returns a list of locals -- all relative to the block
|
||
* specified as an argument to the command. Valid commands include
|
||
* anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
|
||
* and "main").
|
||
*
|
||
* Tcl Arguments:
|
||
* block - the address within which to specify the locals or args.
|
||
* Tcl Result:
|
||
* A list of the locals or args
|
||
*/
|
||
|
||
static int
|
||
gdb_get_vars_command (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
struct symtabs_and_lines sals;
|
||
struct symbol *sym;
|
||
struct block *block;
|
||
char **canonical, *args;
|
||
int i, nsyms, arguments;
|
||
|
||
if (objc != 2)
|
||
{
|
||
Tcl_AppendStringsToObj (result_ptr->obj_ptr,
|
||
"wrong # of args: should be \"",
|
||
Tcl_GetStringFromObj (objv[0], NULL),
|
||
" function:line|function|line|*addr\"", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
arguments = (int) clientData;
|
||
args = Tcl_GetStringFromObj (objv[1], NULL);
|
||
sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
|
||
if (sals.nelts == 0)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr,
|
||
"error decoding line", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Initialize the result pointer to an empty list. */
|
||
|
||
Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
|
||
|
||
/* Resolve all line numbers to PC's */
|
||
for (i = 0; i < sals.nelts; i++)
|
||
resolve_sal_pc (&sals.sals[i]);
|
||
|
||
block = block_for_pc (sals.sals[0].pc);
|
||
while (block != 0)
|
||
{
|
||
nsyms = BLOCK_NSYMS (block);
|
||
for (i = 0; i < nsyms; i++)
|
||
{
|
||
sym = BLOCK_SYM (block, i);
|
||
switch (SYMBOL_CLASS (sym)) {
|
||
default:
|
||
case LOC_UNDEF: /* catches errors */
|
||
case LOC_CONST: /* constant */
|
||
case LOC_TYPEDEF: /* local typedef */
|
||
case LOC_LABEL: /* local label */
|
||
case LOC_BLOCK: /* local function */
|
||
case LOC_CONST_BYTES: /* loc. byte seq. */
|
||
case LOC_UNRESOLVED: /* unresolved static */
|
||
case LOC_OPTIMIZED_OUT: /* optimized out */
|
||
break;
|
||
case LOC_ARG: /* argument */
|
||
case LOC_REF_ARG: /* reference arg */
|
||
case LOC_REGPARM: /* register arg */
|
||
case LOC_REGPARM_ADDR: /* indirect register arg */
|
||
case LOC_LOCAL_ARG: /* stack arg */
|
||
case LOC_BASEREG_ARG: /* basereg arg */
|
||
if (arguments)
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
|
||
Tcl_NewStringObj (SYMBOL_NAME (sym), -1));
|
||
break;
|
||
case LOC_LOCAL: /* stack local */
|
||
case LOC_BASEREG: /* basereg local */
|
||
case LOC_STATIC: /* static */
|
||
case LOC_REGISTER: /* register */
|
||
if (!arguments)
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
|
||
Tcl_NewStringObj (SYMBOL_NAME (sym), -1));
|
||
break;
|
||
}
|
||
}
|
||
if (BLOCK_FUNCTION (block))
|
||
break;
|
||
else
|
||
block = BLOCK_SUPERBLOCK (block);
|
||
}
|
||
|
||
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, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
struct symtabs_and_lines sals;
|
||
char *args, **canonical;
|
||
|
||
if (objc != 2)
|
||
{
|
||
Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
|
||
Tcl_GetStringFromObj (objv[0], NULL),
|
||
" linespec\"", NULL);
|
||
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, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
struct symtabs_and_lines sals;
|
||
char *args, **canonical;
|
||
|
||
if (objc != 2)
|
||
{
|
||
Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
|
||
Tcl_GetStringFromObj (objv[0], NULL),
|
||
" linespec\"", NULL);
|
||
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, interp, objc, objv)
|
||
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_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
|
||
Tcl_GetStringFromObj (objv[0], NULL),
|
||
" linespec\"", NULL);
|
||
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]);
|
||
find_pc_partial_function (sals.sals[0].pc, &function, NULL, NULL);
|
||
if (function != NULL)
|
||
{
|
||
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, or an empty string if the file is not
|
||
* found.
|
||
*/
|
||
|
||
static int
|
||
gdb_find_file_command (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
char *filename = NULL;
|
||
struct symtab *st;
|
||
|
||
if (objc != 2)
|
||
{
|
||
Tcl_WrongNumArgs(interp, 1, objv, "filename");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
st = full_lookup_symtab (Tcl_GetStringFromObj (objv[1], NULL));
|
||
if (st)
|
||
filename = st->fullname;
|
||
|
||
if (filename == NULL)
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "", 0);
|
||
else
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, filename, -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, interp, objc, objv)
|
||
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, "Usage: gdb_listfiles ?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 (file1, file2)
|
||
const void *file1, *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
|
||
* Tcl Result:
|
||
*
|
||
*/
|
||
|
||
static int
|
||
gdb_search (clientData, interp, objc, objv)
|
||
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;
|
||
namespace_enum space = 0;
|
||
char *regexp;
|
||
int static_only, nfiles;
|
||
Tcl_Obj **file_list;
|
||
char **files;
|
||
static char *search_options[] = { "functions", "variables", "types", (char *) NULL };
|
||
static char *switches[] = { "-files", "-static", (char *) NULL };
|
||
enum search_opts { SEARCH_FUNCTIONS, SEARCH_VARIABLES, SEARCH_TYPES };
|
||
enum switches_opts { SWITCH_FILES, SWITCH_STATIC_ONLY };
|
||
|
||
if (objc < 3)
|
||
{
|
||
Tcl_WrongNumArgs (interp, 1, objv, "option regexp ?arg ...?");
|
||
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
|
||
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_FILES:
|
||
{
|
||
int result;
|
||
if (switch_objc < 2)
|
||
{
|
||
Tcl_WrongNumArgs (interp, 2, objv, "[-files fileList -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, 2, objv, "[-files fileList] [-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 ((make_cleanup_func) 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 (SYMBOL_NAME (p->symbol), "__tf", 4)
|
||
&& !STREQN (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_SOURCE_NAME (p->symbol), -1));
|
||
else
|
||
Tcl_ListObjAppendElement (interp, elem,
|
||
Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p->msymbol), -1));
|
||
|
||
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_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
|
||
}
|
||
|
||
symtab = full_lookup_symtab (Tcl_GetStringFromObj (objv[1], NULL));
|
||
if (!symtab)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "No such file", -1);
|
||
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);
|
||
/* Skip the sort if this block is always sorted. */
|
||
if (!BLOCK_SHOULD_SORT (b))
|
||
sort_block_syms (b);
|
||
for (j = 0; j < BLOCK_NSYMS (b); j++)
|
||
{
|
||
sym = BLOCK_SYM (b, j);
|
||
if (SYMBOL_CLASS (sym) == LOC_BLOCK)
|
||
{
|
||
|
||
char *name = cplus_demangle (SYMBOL_NAME(sym), 0);
|
||
if (name)
|
||
{
|
||
/* strip out "global constructors" and "global destructors" */
|
||
/* because we aren't interested in them. */
|
||
if (strncmp (name, "global ", 7))
|
||
{
|
||
funcVals[0] = Tcl_NewStringObj(name, -1);
|
||
funcVals[1] = mangled;
|
||
}
|
||
else
|
||
continue;
|
||
|
||
}
|
||
else
|
||
{
|
||
funcVals[0] = Tcl_NewStringObj(SYMBOL_NAME(sym), -1);
|
||
funcVals[1] = not_mangled;
|
||
}
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
|
||
Tcl_NewListObj (2, funcVals));
|
||
}
|
||
}
|
||
}
|
||
return TCL_OK;
|
||
}
|
||
|
||
|
||
/*
|
||
* This section contains all the commands that act on the registers:
|
||
*/
|
||
|
||
/* This is a sort of mapcar function for operations on registers */
|
||
|
||
static int
|
||
map_arg_registers (objc, objv, func, argp)
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
void (*func) PARAMS ((int regnum, void *argp));
|
||
void *argp;
|
||
{
|
||
int regnum;
|
||
|
||
/* Note that the test for a valid register must include checking the
|
||
REGISTER_NAME because NUM_REGS may be allocated for the union of
|
||
the register sets within a family of related processors. In this
|
||
case, some entries of REGISTER_NAME will change depending upon
|
||
the particular processor being debugged. */
|
||
|
||
if (objc == 0) /* No args, just do all the regs */
|
||
{
|
||
for (regnum = 0;
|
||
regnum < NUM_REGS
|
||
&& REGISTER_NAME (regnum) != NULL
|
||
&& *REGISTER_NAME (regnum) != '\000';
|
||
regnum++)
|
||
func (regnum, argp);
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/* Else, list of register #s, just do listed regs */
|
||
for (; objc > 0; objc--, objv++)
|
||
{
|
||
if (Tcl_GetIntFromObj (NULL, *objv, ®num) != TCL_OK)
|
||
{
|
||
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (regnum >= 0
|
||
&& regnum < NUM_REGS
|
||
&& REGISTER_NAME (regnum) != NULL
|
||
&& *REGISTER_NAME (regnum) != '\000')
|
||
func (regnum, argp);
|
||
else
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "bad register number", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/* This implements the TCL command `gdb_regnames', which returns a list of
|
||
all of the register names. */
|
||
|
||
static int
|
||
gdb_regnames (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
objc--;
|
||
objv++;
|
||
|
||
return map_arg_registers (objc, objv, get_register_name, NULL);
|
||
}
|
||
|
||
static void
|
||
get_register_name (regnum, argp)
|
||
int regnum;
|
||
void *argp; /* Ignored */
|
||
{
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
|
||
Tcl_NewStringObj (REGISTER_NAME (regnum), -1));
|
||
}
|
||
|
||
/* This implements the tcl command gdb_fetch_registers
|
||
* Pass it a list of register names, and it will
|
||
* return their values as a list.
|
||
*
|
||
* Tcl Arguments:
|
||
* format: The format string for printing the values
|
||
* args: the registers to look for
|
||
* Tcl Result:
|
||
* A list of their values.
|
||
*/
|
||
|
||
static int
|
||
gdb_fetch_registers (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
int format, result;
|
||
|
||
if (objc < 2)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr,
|
||
"wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
|
||
}
|
||
objc -= 2;
|
||
objv++;
|
||
format = *(Tcl_GetStringFromObj(objv[0], NULL));
|
||
objv++;
|
||
|
||
|
||
result_ptr->flags |= GDBTK_MAKES_LIST; /* Output the results as a list */
|
||
result = map_arg_registers (objc, objv, get_register, (void *) format);
|
||
result_ptr->flags &= ~GDBTK_MAKES_LIST;
|
||
|
||
return result;
|
||
}
|
||
|
||
static void
|
||
get_register (regnum, fp)
|
||
int regnum;
|
||
void *fp;
|
||
{
|
||
char raw_buffer[MAX_REGISTER_RAW_SIZE];
|
||
char virtual_buffer[MAX_REGISTER_VIRTUAL_SIZE];
|
||
int format = (int)fp;
|
||
int optim;
|
||
|
||
if (format == 'N')
|
||
format = 0;
|
||
|
||
/* read_relative_register_raw_bytes returns a virtual frame pointer
|
||
(FRAME_FP (selected_frame)) if regnum == FP_REGNUM instead
|
||
of the real contents of the register. To get around this,
|
||
use get_saved_register instead. */
|
||
get_saved_register (raw_buffer, &optim, (CORE_ADDR *) NULL, selected_frame,
|
||
regnum, (enum lval_type *) NULL);
|
||
if (optim)
|
||
{
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
|
||
Tcl_NewStringObj ("Optimized out", -1));
|
||
return;
|
||
}
|
||
|
||
/* Convert raw data to virtual format if necessary. */
|
||
|
||
if (REGISTER_CONVERTIBLE (regnum))
|
||
{
|
||
REGISTER_CONVERT_TO_VIRTUAL (regnum, REGISTER_VIRTUAL_TYPE (regnum),
|
||
raw_buffer, virtual_buffer);
|
||
}
|
||
else
|
||
memcpy (virtual_buffer, raw_buffer, REGISTER_VIRTUAL_SIZE (regnum));
|
||
|
||
if (format == 'r')
|
||
{
|
||
int j;
|
||
printf_filtered ("0x");
|
||
for (j = 0; j < REGISTER_RAW_SIZE (regnum); j++)
|
||
{
|
||
register int idx = TARGET_BYTE_ORDER == BIG_ENDIAN ? j
|
||
: REGISTER_RAW_SIZE (regnum) - 1 - j;
|
||
printf_filtered ("%02x", (unsigned char)raw_buffer[idx]);
|
||
}
|
||
}
|
||
else
|
||
val_print (REGISTER_VIRTUAL_TYPE (regnum), virtual_buffer, 0, 0,
|
||
gdb_stdout, format, 1, 0, Val_pretty_default);
|
||
|
||
}
|
||
|
||
/* This implements the tcl command get_pc_reg
|
||
* It returns the value of the PC register
|
||
*
|
||
* Tcl Arguments:
|
||
* None
|
||
* Tcl Result:
|
||
* The value of the pc register.
|
||
*/
|
||
|
||
static int
|
||
get_pc_register (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
char buff[64];
|
||
|
||
sprintf (buff, "0x%llx",(long long) read_register (PC_REGNUM));
|
||
Tcl_SetStringObj(result_ptr->obj_ptr, buff, -1);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/* This implements the tcl command "gdb_changed_register_list"
|
||
* It takes a list of registers, and returns a list of
|
||
* the registers on that list that have changed since the last
|
||
* time the proc was called.
|
||
*
|
||
* Tcl Arguments:
|
||
* A list of registers.
|
||
* Tcl Result:
|
||
* A list of changed registers.
|
||
*/
|
||
|
||
static int
|
||
gdb_changed_register_list (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
objc--;
|
||
objv++;
|
||
|
||
return map_arg_registers (objc, objv, register_changed_p, NULL);
|
||
}
|
||
|
||
static void
|
||
register_changed_p (regnum, argp)
|
||
int regnum;
|
||
void *argp; /* Ignored */
|
||
{
|
||
char raw_buffer[MAX_REGISTER_RAW_SIZE];
|
||
|
||
if (read_relative_register_raw_bytes (regnum, raw_buffer))
|
||
return;
|
||
|
||
if (memcmp (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
|
||
REGISTER_RAW_SIZE (regnum)) == 0)
|
||
return;
|
||
|
||
/* Found a changed register. Save new value and return its number. */
|
||
|
||
memcpy (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
|
||
REGISTER_RAW_SIZE (regnum));
|
||
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj(regnum));
|
||
}
|
||
|
||
/*
|
||
* This section contains the commands that deal with tracepoints:
|
||
*/
|
||
|
||
/* return a list of all tracepoint numbers in interpreter */
|
||
static int
|
||
gdb_get_tracepoint_list (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
struct tracepoint *tp;
|
||
|
||
Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
|
||
|
||
ALL_TRACEPOINTS (tp)
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->number));
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/* returns -1 if not found, tracepoint # if found */
|
||
int
|
||
tracepoint_exists (char * args)
|
||
{
|
||
struct tracepoint *tp;
|
||
char **canonical;
|
||
struct symtabs_and_lines sals;
|
||
char *file = NULL;
|
||
int result = -1;
|
||
|
||
sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
|
||
if (sals.nelts == 1)
|
||
{
|
||
resolve_sal_pc (&sals.sals[0]);
|
||
file = xmalloc (strlen (sals.sals[0].symtab->dirname)
|
||
+ strlen (sals.sals[0].symtab->filename) + 1);
|
||
if (file != NULL)
|
||
{
|
||
strcpy (file, sals.sals[0].symtab->dirname);
|
||
strcat (file, sals.sals[0].symtab->filename);
|
||
|
||
ALL_TRACEPOINTS (tp)
|
||
{
|
||
if (tp->address == sals.sals[0].pc)
|
||
result = tp->number;
|
||
#if 0
|
||
/* Why is this here? This messes up assembly traces */
|
||
else if (tp->source_file != NULL
|
||
&& strcmp (tp->source_file, file) == 0
|
||
&& sals.sals[0].line == tp->line_number)
|
||
result = tp->number;
|
||
#endif
|
||
}
|
||
}
|
||
}
|
||
if (file != NULL)
|
||
free (file);
|
||
return result;
|
||
}
|
||
|
||
static int
|
||
gdb_tracepoint_exists_command (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
char * args;
|
||
|
||
if (objc != 2)
|
||
{
|
||
Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
|
||
Tcl_GetStringFromObj (objv[0], NULL),
|
||
" function:line|function|line|*addr\"", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
args = Tcl_GetStringFromObj (objv[1], NULL);
|
||
|
||
Tcl_SetIntObj (result_ptr->obj_ptr, tracepoint_exists (args));
|
||
return TCL_OK;
|
||
}
|
||
|
||
static int
|
||
gdb_get_tracepoint_info (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
struct symtab_and_line sal;
|
||
int tpnum;
|
||
struct tracepoint *tp;
|
||
struct action_line *al;
|
||
Tcl_Obj *action_list;
|
||
char *filename, *funcname, *fname;
|
||
char tmp[19];
|
||
|
||
if (objc != 2)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (Tcl_GetIntFromObj (NULL, objv[1], &tpnum) != TCL_OK)
|
||
{
|
||
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
ALL_TRACEPOINTS (tp)
|
||
if (tp->number == tpnum)
|
||
break;
|
||
|
||
if (tp == NULL)
|
||
{
|
||
char buff[64];
|
||
sprintf (buff, "Tracepoint #%d does not exist", tpnum);
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, buff, -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
|
||
sal = find_pc_line (tp->address, 0);
|
||
filename = symtab_to_filename (sal.symtab);
|
||
if (filename == NULL)
|
||
filename = "N/A";
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
|
||
Tcl_NewStringObj (filename, -1));
|
||
|
||
find_pc_partial_function (tp->address, &funcname, NULL, NULL);
|
||
fname = cplus_demangle (funcname, 0);
|
||
if (fname)
|
||
{
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewStringObj
|
||
(fname, -1));
|
||
free (fname);
|
||
}
|
||
else
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewStringObj
|
||
(funcname, -1));
|
||
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (sal.line));
|
||
sprintf (tmp, "0x%lx", tp->address);
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewStringObj (tmp, -1));
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->enabled));
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->pass_count));
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->step_count));
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->thread));
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->hit_count));
|
||
|
||
/* Append a list of actions */
|
||
action_list = Tcl_NewObj ();
|
||
for (al = tp->actions; al != NULL; al = al->next)
|
||
{
|
||
Tcl_ListObjAppendElement (interp, action_list,
|
||
Tcl_NewStringObj (al->action, -1));
|
||
}
|
||
Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, action_list);
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
|
||
static int
|
||
gdb_trace_status (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
int result = 0;
|
||
|
||
if (trace_running_p)
|
||
result = 1;
|
||
|
||
Tcl_SetIntObj (result_ptr->obj_ptr, result);
|
||
return TCL_OK;
|
||
}
|
||
|
||
|
||
|
||
static int
|
||
gdb_get_trace_frame_num (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
if (objc != 1)
|
||
{
|
||
Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
|
||
Tcl_GetStringFromObj (objv[0], NULL),
|
||
" linespec\"", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
Tcl_SetIntObj (result_ptr->obj_ptr, get_traceframe_number ());
|
||
return TCL_OK;
|
||
|
||
}
|
||
|
||
/* This implements the tcl command gdb_actions
|
||
* It sets actions for a given tracepoint.
|
||
*
|
||
* Tcl Arguments:
|
||
* number: the tracepoint in question
|
||
* actions: the actions to add to this tracepoint
|
||
* Tcl Result:
|
||
* None.
|
||
*/
|
||
|
||
static int
|
||
gdb_actions_command (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
struct tracepoint *tp;
|
||
Tcl_Obj **actions;
|
||
int nactions, i, len;
|
||
char *number, *args, *action;
|
||
long step_count;
|
||
struct action_line *next = NULL, *temp;
|
||
enum actionline_type linetype;
|
||
|
||
if (objc != 3)
|
||
{
|
||
Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # args: should be: \"",
|
||
Tcl_GetStringFromObj (objv[0], NULL),
|
||
" number actions\"", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
args = number = Tcl_GetStringFromObj (objv[1], NULL);
|
||
tp = get_tracepoint_by_number (&args);
|
||
if (tp == NULL)
|
||
{
|
||
Tcl_AppendStringsToObj (result_ptr->obj_ptr, "Tracepoint \"", number, "\" does not exist", NULL);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
/* Free any existing actions */
|
||
if (tp->actions != NULL)
|
||
free_actions (tp);
|
||
|
||
step_count = 0;
|
||
|
||
Tcl_ListObjGetElements (interp, objv[2], &nactions, &actions);
|
||
|
||
/* Add the actions to the tracepoint */
|
||
for (i = 0; i < nactions; i++)
|
||
{
|
||
temp = xmalloc (sizeof (struct action_line));
|
||
temp->next = NULL;
|
||
action = Tcl_GetStringFromObj (actions[i], &len);
|
||
temp->action = savestring (action, len);
|
||
|
||
linetype = validate_actionline (&(temp->action), tp);
|
||
|
||
if (linetype == BADLINE)
|
||
{
|
||
free (temp);
|
||
continue;
|
||
}
|
||
|
||
if (next == NULL)
|
||
{
|
||
tp->actions = temp;
|
||
next = temp;
|
||
}
|
||
else
|
||
{
|
||
next->next = temp;
|
||
next = temp;
|
||
}
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* This section has commands that handle source disassembly.
|
||
*/
|
||
|
||
/* This implements the tcl command gdb_disassemble
|
||
*
|
||
* Arguments:
|
||
* source_with_assm - must be "source" or "nosource"
|
||
* low_address - the address from which to start disassembly
|
||
* ?hi_address? - the address to which to disassemble, defaults
|
||
* to the end of the function containing low_address.
|
||
* Tcl Result:
|
||
* The disassembled code is passed to fputs_unfiltered, so it
|
||
* either goes to the console if result_ptr->obj_ptr is NULL or to
|
||
* the Tcl result.
|
||
*/
|
||
|
||
static int
|
||
gdb_disassemble (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
CORE_ADDR pc, low, high;
|
||
int mixed_source_and_assembly;
|
||
static disassemble_info di;
|
||
static int di_initialized;
|
||
char *arg_ptr;
|
||
|
||
if (objc != 3 && objc != 4)
|
||
error ("wrong # args");
|
||
|
||
if (! di_initialized)
|
||
{
|
||
INIT_DISASSEMBLE_INFO_NO_ARCH (di, gdb_stdout,
|
||
(fprintf_ftype) fprintf_unfiltered);
|
||
di.flavour = bfd_target_unknown_flavour;
|
||
di.memory_error_func = dis_asm_memory_error;
|
||
di.print_address_func = dis_asm_print_address;
|
||
di_initialized = 1;
|
||
}
|
||
|
||
di.mach = TARGET_PRINT_INSN_INFO->mach;
|
||
if (TARGET_BYTE_ORDER == BIG_ENDIAN)
|
||
di.endian = BFD_ENDIAN_BIG;
|
||
else
|
||
di.endian = BFD_ENDIAN_LITTLE;
|
||
|
||
arg_ptr = Tcl_GetStringFromObj (objv[1], 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
|
||
error ("First arg must be 'source' or 'nosource'");
|
||
|
||
low = parse_and_eval_address (Tcl_GetStringFromObj (objv[2], NULL));
|
||
|
||
if (objc == 3)
|
||
{
|
||
if (find_pc_partial_function (low, NULL, &low, &high) == 0)
|
||
error ("No function contains specified address");
|
||
}
|
||
else
|
||
high = parse_and_eval_address (Tcl_GetStringFromObj (objv[3], NULL));
|
||
|
||
/* 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.
|
||
|
||
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).
|
||
*/
|
||
|
||
if (disassemble_from_exec == -1)
|
||
{
|
||
if (strcmp (target_shortname, "child") == 0
|
||
|| strcmp (target_shortname, "procfs") == 0
|
||
|| strcmp (target_shortname, "vxprocess") == 0)
|
||
disassemble_from_exec = 0; /* It's a child process, read inferior mem */
|
||
else
|
||
disassemble_from_exec = 1; /* It's remote, read the exec file */
|
||
}
|
||
|
||
if (disassemble_from_exec)
|
||
di.read_memory_func = gdbtk_dis_asm_read_memory;
|
||
else
|
||
di.read_memory_func = dis_asm_read_memory;
|
||
|
||
/* 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;
|
||
|
||
symtab = find_pc_symtab (low); /* Assume symtab is valid for whole PC range */
|
||
|
||
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 */
|
||
|
||
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_lines (symtab, next_line, mle[i].line + 1, 0);
|
||
else
|
||
print_source_lines (symtab, mle[i].line, mle[i].line + 1, 0);
|
||
|
||
next_line = mle[i].line + 1;
|
||
}
|
||
|
||
for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
|
||
{
|
||
QUIT;
|
||
fputs_unfiltered (" ", gdb_stdout);
|
||
print_address (pc, gdb_stdout);
|
||
fputs_unfiltered (":\t ", gdb_stdout);
|
||
pc += (*tm_print_insn) (pc, &di);
|
||
fputs_unfiltered ("\n", gdb_stdout);
|
||
}
|
||
}
|
||
}
|
||
else
|
||
{
|
||
assembly_only:
|
||
for (pc = low; pc < high; )
|
||
{
|
||
QUIT;
|
||
fputs_unfiltered (" ", gdb_stdout);
|
||
print_address (pc, gdb_stdout);
|
||
fputs_unfiltered (":\t ", gdb_stdout);
|
||
pc += (*tm_print_insn) (pc, &di);
|
||
fputs_unfiltered ("\n", gdb_stdout);
|
||
}
|
||
}
|
||
|
||
gdb_flush (gdb_stdout);
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/* This is the memory_read_func for gdb_disassemble when we are
|
||
disassembling from the exec file. */
|
||
|
||
static int
|
||
gdbtk_dis_asm_read_memory (memaddr, myaddr, len, info)
|
||
bfd_vma memaddr;
|
||
bfd_byte *myaddr;
|
||
int len;
|
||
disassemble_info *info;
|
||
{
|
||
extern struct target_ops exec_ops;
|
||
int res;
|
||
|
||
errno = 0;
|
||
res = xfer_memory (memaddr, myaddr, len, 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 (mle1p, mle2p)
|
||
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, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
char *filename;
|
||
struct symtab_and_line sal;
|
||
char *funcname, *fname;
|
||
CORE_ADDR pc;
|
||
|
||
if (!have_full_symbols () && !have_partial_symbols ())
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "No symbol table is loaded", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (objc == 1)
|
||
{
|
||
if (selected_frame && (selected_frame->pc != stop_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 hughlighted. */
|
||
/* FIXME */
|
||
pc = selected_frame->pc;
|
||
sal = find_pc_line (selected_frame->pc,
|
||
selected_frame->next != NULL
|
||
&& !selected_frame->next->signal_handler_caller
|
||
&& !frame_in_dummy (selected_frame->next));
|
||
}
|
||
else
|
||
{
|
||
pc = stop_pc;
|
||
sal = find_pc_line (stop_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)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "Ambiguous line spec", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
pc = sal.pc;
|
||
}
|
||
else
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
|
||
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));
|
||
|
||
find_pc_partial_function (pc, &funcname, NULL, NULL);
|
||
fname = cplus_demangle (funcname, 0);
|
||
if (fname)
|
||
{
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
|
||
Tcl_NewStringObj (fname, -1));
|
||
free (fname);
|
||
}
|
||
else
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
|
||
Tcl_NewStringObj (funcname, -1));
|
||
|
||
filename = symtab_to_filename (sal.symtab);
|
||
if (filename == NULL)
|
||
filename = "";
|
||
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
|
||
Tcl_NewStringObj (filename, -1));
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj(sal.line)); /* line number */
|
||
sprintf_append_element_to_obj (result_ptr->obj_ptr, "0x%s", paddr_nz(pc)); /* PC in current frame */
|
||
sprintf_append_element_to_obj (result_ptr->obj_ptr, "0x%s", paddr_nz(stop_pc)); /* Real PC */
|
||
return TCL_OK;
|
||
}
|
||
|
||
/* This implements the Tcl command 'gdb_get_mem', which
|
||
* dumps a block of memory
|
||
* Arguments:
|
||
* gdb_get_mem addr form size num aschar
|
||
*
|
||
* addr: address of data to dump
|
||
* form: a char indicating format
|
||
* size: size of each element; 1,2,4, or 8 bytes
|
||
* num: the number of bytes to read
|
||
* acshar: an optional ascii character to use in ASCII dump
|
||
*
|
||
* Return:
|
||
* a list of elements followed by an optional ASCII dump
|
||
*/
|
||
|
||
static int
|
||
gdb_get_mem (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
int size, asize, i, j, bc;
|
||
CORE_ADDR addr;
|
||
int nbytes, rnum, bpr;
|
||
long tmp;
|
||
char format, c, buff[128], aschar, *mbuf, *mptr, *cptr, *bptr;
|
||
struct type *val_type;
|
||
|
||
if (objc < 6 || objc > 7)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr,
|
||
"addr format size bytes bytes_per_row ?ascii_char?", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (Tcl_GetIntFromObj (interp, objv[3], &size) != TCL_OK)
|
||
{
|
||
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
else if (size <= 0)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "Invalid size, must be > 0", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (Tcl_GetIntFromObj (interp, objv[4], &nbytes) != TCL_OK)
|
||
{
|
||
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
else if (size <= 0)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "Invalid number of bytes, must be > 0",
|
||
-1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (Tcl_GetIntFromObj (interp, objv[5], &bpr) != TCL_OK)
|
||
{
|
||
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
else if (size <= 0)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "Invalid bytes per row, must be > 0", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (Tcl_GetLongFromObj (interp, objv[1], &tmp) != TCL_OK)
|
||
return TCL_OK;
|
||
|
||
addr = (CORE_ADDR) tmp;
|
||
|
||
format = *(Tcl_GetStringFromObj (objv[2], NULL));
|
||
mbuf = (char *)malloc (nbytes+32);
|
||
if (!mbuf)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "Out of memory.", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
memset (mbuf, 0, nbytes+32);
|
||
mptr = cptr = mbuf;
|
||
|
||
rnum = target_read_memory_partial (addr, mbuf, nbytes, NULL);
|
||
|
||
if (objc == 7)
|
||
aschar = *(Tcl_GetStringFromObj(objv[6], NULL));
|
||
else
|
||
aschar = 0;
|
||
|
||
switch (size) {
|
||
case 1:
|
||
val_type = builtin_type_char;
|
||
asize = 'b';
|
||
break;
|
||
case 2:
|
||
val_type = builtin_type_short;
|
||
asize = 'h';
|
||
break;
|
||
case 4:
|
||
val_type = builtin_type_int;
|
||
asize = 'w';
|
||
break;
|
||
case 8:
|
||
val_type = builtin_type_long_long;
|
||
asize = 'g';
|
||
break;
|
||
default:
|
||
val_type = builtin_type_char;
|
||
asize = 'b';
|
||
}
|
||
|
||
bc = 0; /* count of bytes in a row */
|
||
buff[0] = '"'; /* buffer for ascii dump */
|
||
bptr = &buff[1]; /* pointer for ascii dump */
|
||
|
||
result_ptr->flags |= GDBTK_MAKES_LIST; /* Build up the result as a list... */
|
||
|
||
for (i=0; i < nbytes; i+= size)
|
||
{
|
||
if ( i >= rnum)
|
||
{
|
||
fputs_unfiltered ("N/A ", gdb_stdout);
|
||
if (aschar)
|
||
for ( j = 0; j < size; j++)
|
||
*bptr++ = 'X';
|
||
}
|
||
else
|
||
{
|
||
print_scalar_formatted (mptr, val_type, format, asize, gdb_stdout);
|
||
|
||
if (aschar)
|
||
{
|
||
for ( j = 0; j < size; j++)
|
||
{
|
||
c = *cptr++;
|
||
if (c < 32 || c > 126)
|
||
c = aschar;
|
||
if (c == '"')
|
||
*bptr++ = '\\';
|
||
*bptr++ = c;
|
||
}
|
||
}
|
||
}
|
||
|
||
mptr += size;
|
||
bc += size;
|
||
|
||
if (aschar && (bc >= bpr))
|
||
{
|
||
/* end of row. print it and reset variables */
|
||
bc = 0;
|
||
*bptr++ = '"';
|
||
*bptr++ = ' ';
|
||
*bptr = 0;
|
||
fputs_unfiltered (buff, gdb_stdout);
|
||
bptr = &buff[1];
|
||
}
|
||
}
|
||
|
||
result_ptr->flags &= ~GDBTK_MAKES_LIST;
|
||
|
||
free (mbuf);
|
||
return TCL_OK;
|
||
}
|
||
|
||
|
||
|
||
/* 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, interp, objc, objv)
|
||
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;
|
||
Tcl_DString text_cmd_1, text_cmd_2, *cur_cmd;
|
||
char line[1024], line_num_buf[16];
|
||
int prefix_len_1, prefix_len_2, cur_prefix_len, widget_len;
|
||
|
||
|
||
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;
|
||
}
|
||
|
||
file = Tcl_GetStringFromObj (objv[2], NULL);
|
||
Tcl_GetBooleanFromObj (interp, objv[3], &linenumbers);
|
||
|
||
symtab = full_lookup_symtab (file);
|
||
if (!symtab)
|
||
{
|
||
Tcl_SetStringObj ( result_ptr->obj_ptr, "File not found in symtab", -1);
|
||
fclose (fp);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
file = symtab_to_filename ( symtab );
|
||
if ((fp = fopen ( file, "r" )) == NULL)
|
||
{
|
||
Tcl_SetStringObj ( result_ptr->obj_ptr, "Can't open file for reading", -1);
|
||
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("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)
|
||
{
|
||
Tcl_SetStringObj ( result_ptr->obj_ptr, "Out of memory.", -1);
|
||
fclose (fp);
|
||
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)
|
||
{
|
||
Tcl_SetStringObj ( result_ptr->obj_ptr, "Out of memory.", -1);
|
||
free (ltable);
|
||
fclose (fp);
|
||
return TCL_ERROR;
|
||
}
|
||
ltable = new_ltable;
|
||
}
|
||
ltable[lnum] |= 1 << (le->line % 8);
|
||
}
|
||
}
|
||
|
||
Tcl_DStringInit(&text_cmd_1);
|
||
Tcl_DStringInit(&text_cmd_2);
|
||
|
||
ln = 1;
|
||
|
||
widget_len = strlen (widget);
|
||
line[0] = '\t';
|
||
|
||
Tcl_DStringAppend (&text_cmd_1, widget, widget_len);
|
||
Tcl_DStringAppend (&text_cmd_2, widget, widget_len);
|
||
|
||
if (linenumbers)
|
||
{
|
||
Tcl_DStringAppend (&text_cmd_1, " insert end {-\t", -1);
|
||
prefix_len_1 = Tcl_DStringLength(&text_cmd_1);
|
||
|
||
Tcl_DStringAppend (&text_cmd_2, " insert end { \t", -1);
|
||
prefix_len_2 = Tcl_DStringLength(&text_cmd_2);
|
||
|
||
while (fgets (line + 1, 980, fp))
|
||
{
|
||
sprintf (line_num_buf, "%d", ln);
|
||
if (ltable[ln >> 3] & (1 << (ln % 8)))
|
||
{
|
||
cur_cmd = &text_cmd_1;
|
||
cur_prefix_len = prefix_len_1;
|
||
Tcl_DStringAppend (cur_cmd, line_num_buf, -1);
|
||
Tcl_DStringAppend (cur_cmd, "} break_rgn_tag", 15);
|
||
}
|
||
else
|
||
{
|
||
cur_cmd = &text_cmd_2;
|
||
cur_prefix_len = prefix_len_2;
|
||
Tcl_DStringAppend (cur_cmd, line_num_buf, -1);
|
||
Tcl_DStringAppend (cur_cmd, "} \"\"", 4);
|
||
}
|
||
|
||
Tcl_DStringAppendElement (cur_cmd, line);
|
||
Tcl_DStringAppend (cur_cmd, " source_tag", 11);
|
||
|
||
Tcl_Eval(interp, Tcl_DStringValue(cur_cmd));
|
||
Tcl_DStringSetLength(cur_cmd, cur_prefix_len);
|
||
ln++;
|
||
}
|
||
}
|
||
else
|
||
{
|
||
Tcl_DStringAppend (&text_cmd_1, " insert end {- } break_rgn_tag", -1);
|
||
prefix_len_1 = Tcl_DStringLength(&text_cmd_1);
|
||
Tcl_DStringAppend (&text_cmd_2, " insert end { } \"\"", -1);
|
||
prefix_len_2 = Tcl_DStringLength(&text_cmd_2);
|
||
|
||
while (fgets (line + 1, 980, fp))
|
||
{
|
||
if (ltable[ln >> 3] & (1 << (ln % 8)))
|
||
{
|
||
cur_cmd = &text_cmd_1;
|
||
cur_prefix_len = prefix_len_1;
|
||
}
|
||
else
|
||
{
|
||
cur_cmd = &text_cmd_2;
|
||
cur_prefix_len = prefix_len_2;
|
||
}
|
||
|
||
Tcl_DStringAppendElement (cur_cmd, line);
|
||
Tcl_DStringAppend (cur_cmd, " source_tag", 11);
|
||
|
||
Tcl_Eval(interp, Tcl_DStringValue(cur_cmd));
|
||
Tcl_DStringSetLength(cur_cmd, cur_prefix_len);
|
||
|
||
ln++;
|
||
}
|
||
}
|
||
|
||
Tcl_DStringFree (&text_cmd_1);
|
||
Tcl_DStringFree (&text_cmd_2);
|
||
free (ltable);
|
||
fclose (fp);
|
||
return TCL_OK;
|
||
}
|
||
|
||
/*
|
||
* This section contains commands for manipulation of breakpoints.
|
||
*/
|
||
|
||
|
||
/* set a breakpoint by source file and line number */
|
||
/* flags are as follows: */
|
||
/* least significant 2 bits are disposition, rest is */
|
||
/* type (normally 0).
|
||
|
||
enum bptype {
|
||
bp_breakpoint, Normal breakpoint
|
||
bp_hardware_breakpoint, Hardware assisted breakpoint
|
||
}
|
||
|
||
Disposition of breakpoint. Ie: what to do after hitting it.
|
||
enum bpdisp {
|
||
del, Delete it
|
||
del_at_next_stop, Delete at next stop, whether hit or not
|
||
disable, Disable it
|
||
donttouch Leave it alone
|
||
};
|
||
*/
|
||
|
||
/* This implements the tcl command "gdb_set_bp"
|
||
* It sets breakpoints, and runs the Tcl command
|
||
* gdbtk_tcl_breakpoint create
|
||
* to register the new breakpoint with the GUI.
|
||
*
|
||
* Tcl Arguments:
|
||
* filename: the file in which to set the breakpoint
|
||
* line: the line number for the breakpoint
|
||
* type: the type of the breakpoint
|
||
* thread: optional thread number
|
||
* Tcl Result:
|
||
* The return value of the call to gdbtk_tcl_breakpoint.
|
||
*/
|
||
|
||
static int
|
||
gdb_set_bp (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
|
||
{
|
||
struct symtab_and_line sal;
|
||
int line, flags, ret, thread = -1;
|
||
struct breakpoint *b;
|
||
char buf[64];
|
||
Tcl_DString cmd;
|
||
|
||
if (objc != 4 && objc != 5)
|
||
{
|
||
Tcl_WrongNumArgs(interp, 1, objv, "filename line type [thread]");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
sal.symtab = full_lookup_symtab (Tcl_GetStringFromObj( objv[1], NULL));
|
||
if (sal.symtab == NULL)
|
||
return TCL_ERROR;
|
||
|
||
if (Tcl_GetIntFromObj( interp, objv[2], &line) == TCL_ERROR)
|
||
{
|
||
result_ptr->flags = GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (Tcl_GetIntFromObj( interp, objv[3], &flags) == TCL_ERROR)
|
||
{
|
||
result_ptr->flags = GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (objc == 5)
|
||
{
|
||
if (Tcl_GetIntFromObj( interp, objv[4], &thread) == TCL_ERROR)
|
||
{
|
||
result_ptr->flags = GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
sal.line = line;
|
||
if (!find_line_pc (sal.symtab, sal.line, &sal.pc))
|
||
return TCL_ERROR;
|
||
|
||
sal.section = find_pc_overlay (sal.pc);
|
||
b = set_raw_breakpoint (sal);
|
||
set_breakpoint_count (breakpoint_count + 1);
|
||
b->number = breakpoint_count;
|
||
b->type = flags >> 2;
|
||
b->disposition = flags & 3;
|
||
b->thread = thread;
|
||
|
||
/* FIXME: this won't work for duplicate basenames! */
|
||
sprintf (buf, "%s:%d", basename (Tcl_GetStringFromObj ( objv[1], NULL)), line);
|
||
b->addr_string = strsave (buf);
|
||
|
||
/* now send notification command back to GUI */
|
||
|
||
Tcl_DStringInit (&cmd);
|
||
|
||
Tcl_DStringAppend (&cmd, "gdbtk_tcl_breakpoint create ", -1);
|
||
sprintf (buf, "%d", b->number);
|
||
Tcl_DStringAppendElement(&cmd, buf);
|
||
sprintf (buf, "0x%lx", (long)sal.pc);
|
||
Tcl_DStringAppendElement (&cmd, buf);
|
||
Tcl_DStringAppendElement (&cmd, Tcl_GetStringFromObj (objv[2], NULL));
|
||
Tcl_DStringAppendElement (&cmd, Tcl_GetStringFromObj (objv[1], NULL));
|
||
Tcl_DStringAppendElement (&cmd, bpdisp[b->disposition]);
|
||
sprintf (buf, "%d", b->enable);
|
||
Tcl_DStringAppendElement (&cmd, buf);
|
||
sprintf (buf, "%d", b->thread);
|
||
Tcl_DStringAppendElement (&cmd, buf);
|
||
|
||
|
||
ret = Tcl_Eval (interp, Tcl_DStringValue (&cmd));
|
||
Tcl_DStringFree (&cmd);
|
||
return ret;
|
||
}
|
||
|
||
/* This implements the tcl command "gdb_set_bp_addr"
|
||
* It sets breakpoints, and runs the Tcl command
|
||
* gdbtk_tcl_breakpoint create
|
||
* to register the new breakpoint with the GUI.
|
||
*
|
||
* Tcl Arguments:
|
||
* addr: the address at which to set the breakpoint
|
||
* type: the type of the breakpoint
|
||
* thread: optional thread number
|
||
* Tcl Result:
|
||
* The return value of the call to gdbtk_tcl_breakpoint.
|
||
*/
|
||
|
||
static int
|
||
gdb_set_bp_addr (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
|
||
{
|
||
struct symtab_and_line sal;
|
||
int line, flags, ret, thread = -1;
|
||
long addr;
|
||
struct breakpoint *b;
|
||
char *filename, buf[64];
|
||
Tcl_DString cmd;
|
||
|
||
if (objc != 4 && objc != 3)
|
||
{
|
||
Tcl_WrongNumArgs(interp, 1, objv, "addr type ?thread?");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (Tcl_GetLongFromObj( interp, objv[1], &addr) == TCL_ERROR)
|
||
{
|
||
result_ptr->flags = GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (Tcl_GetIntFromObj( interp, objv[2], &flags) == TCL_ERROR)
|
||
{
|
||
result_ptr->flags = GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (objc == 4)
|
||
{
|
||
if (Tcl_GetIntFromObj( interp, objv[3], &thread) == TCL_ERROR)
|
||
{
|
||
result_ptr->flags = GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
}
|
||
|
||
sal = find_pc_line (addr, 0);
|
||
sal.pc = addr;
|
||
b = set_raw_breakpoint (sal);
|
||
set_breakpoint_count (breakpoint_count + 1);
|
||
b->number = breakpoint_count;
|
||
b->type = flags >> 2;
|
||
b->disposition = flags & 3;
|
||
b->thread = thread;
|
||
|
||
sprintf (buf, "*(0x%lx)",addr);
|
||
b->addr_string = strsave (buf);
|
||
|
||
/* now send notification command back to GUI */
|
||
|
||
Tcl_DStringInit (&cmd);
|
||
|
||
Tcl_DStringAppend (&cmd, "gdbtk_tcl_breakpoint create ", -1);
|
||
sprintf (buf, "%d", b->number);
|
||
Tcl_DStringAppendElement(&cmd, buf);
|
||
sprintf (buf, "0x%lx", addr);
|
||
Tcl_DStringAppendElement (&cmd, buf);
|
||
sprintf (buf, "%d", b->line_number);
|
||
Tcl_DStringAppendElement (&cmd, buf);
|
||
|
||
filename = symtab_to_filename (sal.symtab);
|
||
if (filename == NULL)
|
||
filename = "";
|
||
Tcl_DStringAppendElement (&cmd, filename);
|
||
Tcl_DStringAppendElement (&cmd, bpdisp[b->disposition]);
|
||
sprintf (buf, "%d", b->enable);
|
||
Tcl_DStringAppendElement (&cmd, buf);
|
||
sprintf (buf, "%d", b->thread);
|
||
Tcl_DStringAppendElement (&cmd, buf);
|
||
|
||
ret = Tcl_Eval (interp, Tcl_DStringValue (&cmd));
|
||
Tcl_DStringFree (&cmd);
|
||
return ret;
|
||
}
|
||
|
||
/* This implements the tcl command "gdb_find_bp_at_line"
|
||
*
|
||
* Tcl Arguments:
|
||
* filename: the file in which to find the breakpoint
|
||
* line: the line number for the breakpoint
|
||
* Tcl Result:
|
||
* It returns a list of breakpoint numbers
|
||
*/
|
||
|
||
static int
|
||
gdb_find_bp_at_line(clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
|
||
{
|
||
struct symtab *s;
|
||
int line;
|
||
struct breakpoint *b;
|
||
extern struct breakpoint *breakpoint_chain;
|
||
|
||
if (objc != 3)
|
||
{
|
||
Tcl_WrongNumArgs(interp, 1, objv, "filename line");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
s = full_lookup_symtab (Tcl_GetStringFromObj( objv[1], NULL));
|
||
if (s == NULL)
|
||
return TCL_ERROR;
|
||
|
||
if (Tcl_GetIntFromObj( interp, objv[2], &line) == TCL_ERROR)
|
||
{
|
||
result_ptr->flags = GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
Tcl_SetListObj (result_ptr->obj_ptr ,0 ,NULL);
|
||
for (b = breakpoint_chain; b; b = b->next)
|
||
if (b->line_number == line && !strcmp(b->source_file, s->filename))
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
|
||
Tcl_NewIntObj (b->number));
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
|
||
/* This implements the tcl command "gdb_find_bp_at_addr"
|
||
*
|
||
* Tcl Arguments:
|
||
* addr: address
|
||
* Tcl Result:
|
||
* It returns a list of breakpoint numbers
|
||
*/
|
||
|
||
static int
|
||
gdb_find_bp_at_addr(clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
|
||
{
|
||
long addr;
|
||
struct breakpoint *b;
|
||
extern struct breakpoint *breakpoint_chain;
|
||
|
||
if (objc != 2)
|
||
{
|
||
Tcl_WrongNumArgs(interp, 1, objv, "address");
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (Tcl_GetLongFromObj( interp, objv[1], &addr) == TCL_ERROR)
|
||
{
|
||
result_ptr->flags = GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
Tcl_SetListObj (result_ptr->obj_ptr ,0 ,NULL);
|
||
for (b = breakpoint_chain; b; b = b->next)
|
||
if (b->address == (CORE_ADDR)addr)
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
|
||
Tcl_NewIntObj (b->number));
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/* This implements the tcl command gdb_get_breakpoint_info
|
||
*
|
||
*
|
||
* Tcl Arguments:
|
||
* breakpoint_number
|
||
* Tcl Result:
|
||
* A list with {file, function, line_number, address, type, enabled?,
|
||
* disposition, ignore_count, {list_of_commands}, thread, hit_count}
|
||
*/
|
||
|
||
static int
|
||
gdb_get_breakpoint_info (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
struct symtab_and_line sal;
|
||
struct command_line *cmd;
|
||
int bpnum;
|
||
struct breakpoint *b;
|
||
extern struct breakpoint *breakpoint_chain;
|
||
char *funcname, *fname, *filename;
|
||
Tcl_Obj *new_obj;
|
||
|
||
if (objc != 2)
|
||
{
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, "wrong number of args, should be \"breakpoint\"", -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if ( Tcl_GetIntFromObj(NULL, objv[1], &bpnum) != TCL_OK)
|
||
{
|
||
result_ptr->flags = GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
for (b = breakpoint_chain; b; b = b->next)
|
||
if (b->number == bpnum)
|
||
break;
|
||
|
||
if (!b || b->type != bp_breakpoint)
|
||
{
|
||
char err_buf[64];
|
||
sprintf(err_buf, "Breakpoint #%d does not exist.", bpnum);
|
||
Tcl_SetStringObj (result_ptr->obj_ptr, err_buf, -1);
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
sal = find_pc_line (b->address, 0);
|
||
|
||
filename = symtab_to_filename (sal.symtab);
|
||
if (filename == NULL)
|
||
filename = "";
|
||
|
||
Tcl_SetListObj (result_ptr->obj_ptr ,0 ,NULL);
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
|
||
Tcl_NewStringObj (filename, -1));
|
||
|
||
find_pc_partial_function (b->address, &funcname, NULL, NULL);
|
||
fname = cplus_demangle (funcname, 0);
|
||
if (fname)
|
||
{
|
||
new_obj = Tcl_NewStringObj (fname, -1);
|
||
free (fname);
|
||
}
|
||
else
|
||
new_obj = Tcl_NewStringObj (funcname, -1);
|
||
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, new_obj);
|
||
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (b->line_number));
|
||
sprintf_append_element_to_obj (result_ptr->obj_ptr, "0x%lx", b->address);
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
|
||
Tcl_NewStringObj (bptypes[b->type], -1));
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewBooleanObj(b->enable == enabled));
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
|
||
Tcl_NewStringObj (bpdisp[b->disposition], -1));
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (b->ignore_count));
|
||
|
||
new_obj = Tcl_NewObj();
|
||
for (cmd = b->commands; cmd; cmd = cmd->next)
|
||
Tcl_ListObjAppendElement (NULL, new_obj,
|
||
Tcl_NewStringObj (cmd->line, -1));
|
||
Tcl_ListObjAppendElement(NULL, result_ptr->obj_ptr, new_obj);
|
||
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
|
||
Tcl_NewStringObj (b->cond_string, -1));
|
||
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (b->thread));
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (b->hit_count));
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
|
||
/* This implements the tcl command gdb_get_breakpoint_list
|
||
* It builds up a list of the current breakpoints.
|
||
*
|
||
* Tcl Arguments:
|
||
* None.
|
||
* Tcl Result:
|
||
* A list of breakpoint numbers.
|
||
*/
|
||
|
||
static int
|
||
gdb_get_breakpoint_list (clientData, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
struct breakpoint *b;
|
||
extern struct breakpoint *breakpoint_chain;
|
||
Tcl_Obj *new_obj;
|
||
|
||
if (objc != 1)
|
||
error ("wrong number of args, none are allowed");
|
||
|
||
for (b = breakpoint_chain; b; b = b->next)
|
||
if (b->type == bp_breakpoint)
|
||
{
|
||
new_obj = Tcl_NewIntObj (b->number);
|
||
Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, new_obj);
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/* The functions in this section deal with stacks and backtraces. */
|
||
|
||
/* This implements the tcl command gdb_stack.
|
||
* It builds up a list of stack frames.
|
||
*
|
||
* Tcl Arguments:
|
||
* start - starting stack frame
|
||
* count - number of frames to inspect
|
||
* Tcl Result:
|
||
* A list of function names
|
||
*/
|
||
|
||
static int
|
||
gdb_stack (clientData, interp, objc, objv) ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
int start, count;
|
||
|
||
if (objc < 3)
|
||
{
|
||
Tcl_WrongNumArgs (interp, 1, objv, "start count");
|
||
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
if (Tcl_GetIntFromObj (NULL, objv[1], &start))
|
||
{
|
||
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
if (Tcl_GetIntFromObj (NULL, objv[2], &count))
|
||
{
|
||
result_ptr->flags |= GDBTK_IN_TCL_RESULT;
|
||
return TCL_ERROR;
|
||
}
|
||
|
||
Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
|
||
|
||
if (target_has_stack)
|
||
{
|
||
struct frame_info *top;
|
||
struct frame_info *fi;
|
||
|
||
/* Find the outermost frame */
|
||
fi = get_current_frame ();
|
||
while (fi != NULL)
|
||
{
|
||
top = fi;
|
||
fi = get_prev_frame (fi);
|
||
}
|
||
|
||
/* top now points to the top (outermost frame) of the
|
||
stack, so point it to the requested start */
|
||
start = -start;
|
||
top = find_relative_frame (top, &start);
|
||
|
||
/* If start != 0, then we have asked to start outputting
|
||
frames beyond the innermost stack frame */
|
||
if (start == 0)
|
||
{
|
||
fi = top;
|
||
while (fi && count--)
|
||
{
|
||
get_frame_name (interp, result_ptr->obj_ptr, fi);
|
||
fi = get_next_frame (fi);
|
||
}
|
||
}
|
||
}
|
||
|
||
return TCL_OK;
|
||
}
|
||
|
||
/* A helper function for get_stack which adds information about
|
||
* the stack frame FI to the caller's LIST.
|
||
*
|
||
* This is stolen from print_frame_info in stack.c.
|
||
*/
|
||
static void
|
||
get_frame_name (interp, list, fi)
|
||
Tcl_Interp *interp;
|
||
Tcl_Obj *list;
|
||
struct frame_info *fi;
|
||
{
|
||
struct symtab_and_line sal;
|
||
struct symbol *func = NULL;
|
||
register char *funname = 0;
|
||
enum language funlang = language_unknown;
|
||
Tcl_Obj *objv[1];
|
||
|
||
if (frame_in_dummy (fi))
|
||
{
|
||
objv[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
|
||
Tcl_ListObjAppendElement (interp, list, objv[0]);
|
||
return;
|
||
}
|
||
if (fi->signal_handler_caller)
|
||
{
|
||
objv[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
|
||
Tcl_ListObjAppendElement (interp, list, objv[0]);
|
||
return;
|
||
}
|
||
|
||
sal =
|
||
find_pc_line (fi->pc,
|
||
fi->next != NULL
|
||
&& !fi->next->signal_handler_caller
|
||
&& !frame_in_dummy (fi->next));
|
||
|
||
func = find_pc_function (fi->pc);
|
||
if (func)
|
||
{
|
||
struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
|
||
if (msymbol != NULL
|
||
&& (SYMBOL_VALUE_ADDRESS (msymbol)
|
||
> BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
|
||
{
|
||
func = 0;
|
||
funname = SYMBOL_NAME (msymbol);
|
||
funlang = SYMBOL_LANGUAGE (msymbol);
|
||
}
|
||
else
|
||
{
|
||
funname = SYMBOL_NAME (func);
|
||
funlang = SYMBOL_LANGUAGE (func);
|
||
}
|
||
}
|
||
else
|
||
{
|
||
struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
|
||
if (msymbol != NULL)
|
||
{
|
||
funname = SYMBOL_NAME (msymbol);
|
||
funlang = SYMBOL_LANGUAGE (msymbol);
|
||
}
|
||
}
|
||
|
||
if (sal.symtab)
|
||
{
|
||
char *name = NULL;
|
||
|
||
if (funlang == language_cplus)
|
||
name = cplus_demangle (funname, 0);
|
||
if (name == NULL)
|
||
name = funname;
|
||
|
||
objv[0] = Tcl_NewStringObj (name, -1);
|
||
Tcl_ListObjAppendElement (interp, list, objv[0]);
|
||
}
|
||
else
|
||
{
|
||
#if 0
|
||
/* we have no convenient way to deal with this yet... */
|
||
if (fi->pc != sal.pc || !sal.symtab)
|
||
{
|
||
print_address_numeric (fi->pc, 1, gdb_stdout);
|
||
printf_filtered (" in ");
|
||
}
|
||
fprintf_symbol_filtered (gdb_stdout, funname ? funname : "??", funlang,
|
||
DMGL_ANSI);
|
||
#endif
|
||
objv[0] = Tcl_NewStringObj (funname != NULL ? funname : "??", -1);
|
||
#ifdef PC_LOAD_SEGMENT
|
||
/* If we couldn't print out function name but if can figure out what
|
||
load segment this pc value is from, at least print out some info
|
||
about its load segment. */
|
||
if (!funname)
|
||
{
|
||
Tcl_AppendStringsToObj (objv[0], " from ", PC_LOAD_SEGMENT (fi->pc),
|
||
(char *) NULL);
|
||
}
|
||
#endif
|
||
#ifdef PC_SOLIB
|
||
if (!funname)
|
||
{
|
||
char *lib = PC_SOLIB (fi->pc);
|
||
if (lib)
|
||
{
|
||
Tcl_AppendStringsToObj (objv[0], " from ", lib, (char *) NULL);
|
||
}
|
||
}
|
||
#endif
|
||
Tcl_ListObjAppendElement (interp, list, objv[0]);
|
||
}
|
||
}
|
||
|
||
|
||
/*
|
||
* 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, interp, objc, objv)
|
||
ClientData clientData;
|
||
Tcl_Interp *interp;
|
||
int objc;
|
||
Tcl_Obj *CONST objv[];
|
||
{
|
||
if (objc != 2)
|
||
error ("wrong # args");
|
||
|
||
#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 (args)
|
||
char * args;
|
||
{
|
||
perror_with_name (args);
|
||
return 1;
|
||
}
|
||
|
||
/* The lookup_symtab() in symtab.c doesn't work correctly */
|
||
/* It will not work will full pathnames and if multiple */
|
||
/* source files have the same basename, it will return */
|
||
/* the first one instead of the correct one. This version */
|
||
/* also always makes sure symtab->fullname is set. */
|
||
|
||
static struct symtab *
|
||
full_lookup_symtab(file)
|
||
char *file;
|
||
{
|
||
struct symtab *st;
|
||
struct objfile *objfile;
|
||
char *bfile, *fullname;
|
||
struct partial_symtab *pt;
|
||
|
||
if (!file)
|
||
return NULL;
|
||
|
||
/* first try a direct lookup */
|
||
st = lookup_symtab (file);
|
||
if (st)
|
||
{
|
||
if (!st->fullname)
|
||
symtab_to_filename(st);
|
||
return st;
|
||
}
|
||
|
||
/* if the direct approach failed, try */
|
||
/* looking up the basename and checking */
|
||
/* all matches with the fullname */
|
||
bfile = basename (file);
|
||
ALL_SYMTABS (objfile, st)
|
||
{
|
||
if (!strcmp (bfile, basename(st->filename)))
|
||
{
|
||
if (!st->fullname)
|
||
fullname = symtab_to_filename (st);
|
||
else
|
||
fullname = st->fullname;
|
||
|
||
if (!strcmp (file, fullname))
|
||
return st;
|
||
}
|
||
}
|
||
|
||
/* still no luck? look at psymtabs */
|
||
ALL_PSYMTABS (objfile, pt)
|
||
{
|
||
if (!strcmp (bfile, basename(pt->filename)))
|
||
{
|
||
st = PSYMTAB_TO_SYMTAB (pt);
|
||
if (st)
|
||
{
|
||
fullname = symtab_to_filename (st);
|
||
if (!strcmp (file, fullname))
|
||
return st;
|
||
}
|
||
}
|
||
}
|
||
return NULL;
|
||
}
|