diff options
Diffstat (limited to 'gdb')
| -rw-r--r-- | gdb/ChangeLog-gdbtk | 24 | ||||
| -rw-r--r-- | gdb/Makefile.in | 19 | ||||
| -rwxr-xr-x | gdb/configure | 2 | ||||
| -rw-r--r-- | gdb/configure.in | 2 | ||||
| -rw-r--r-- | gdb/gdbtk.c | 3225 | ||||
| -rw-r--r-- | gdb/gdbtk.h | 145 | ||||
| -rw-r--r-- | gdb/gdbtk_cmds.c | 3075 | ||||
| -rw-r--r-- | gdb/gdbtk_hooks.c | 689 |
8 files changed, 4092 insertions, 3089 deletions
diff --git a/gdb/ChangeLog-gdbtk b/gdb/ChangeLog-gdbtk index 3710799..e84b739 100644 --- a/gdb/ChangeLog-gdbtk +++ b/gdb/ChangeLog-gdbtk @@ -1,3 +1,27 @@ +Wed Jul 1 11:07:21 1998 Jim Ingham <jingham@cygnus.com> + + * gdbtk.c: removed all the commands and hooks from this file so + now it contains only the startup code. + * gdbtk.c (gdbtk_init): Fixed a bug in the startup code on Windows + that caused gdbtk not to find the share directory unless + GDBTK_LIBRARY was set. + * gdbtk_cmds.c: New file - this contains all the Tcl commands that + gdb defines. All the old commands were moved here, the + string-based commands were converted to object commands, and the + object-based commands were all converted to uniformly use the + call_wrapper. A new function, Gdbtk_Init was added to centralize + initializing the gdb package. + * gdbtk_hooks.c: New file - All the hooks were moved here, and a new + function, gdbtk_add_hooks was added to centralize adding all these + hook functions. gdbtk_fputs was also modified to handle the new + result_ptr structure. See the comments in gdbtk.h for more + details. + * gdbtk.h: New file - this contains all the defines and globals + shared by gdbtk.c, gdbtk_cmds.c & gdbtk_hooks.c + * Makefile.in, configure.in & configure: mutatis mutandi for the + new files. + + Mon Jun 29 11:49:17 1998 Keith Seitz <keiths@cygnus.com> * main.c (main): Don't include gdbtk test code if GDBTK is diff --git a/gdb/Makefile.in b/gdb/Makefile.in index 1b9a8fd..3609c2d 100644 --- a/gdb/Makefile.in +++ b/gdb/Makefile.in @@ -618,9 +618,10 @@ install-only: $(datadir)/gdbtcl/images \ $(datadir)/gdbtcl/images2 ; \ $(SHELL) $(srcdir)/../mkinstalldirs $(datadir)/gdbtcl/help \ - $(datadir)/gdbtcl/help/images; \ + $(datadir)/gdbtcl/help/images \ + $(datadir)/gdbtcl/help/trace ; \ cd $(srcdir)/gdbtcl2 ; \ - for i in *.tcl images/*.gif images2/*.gif images/icons.txt images2/icons.txt tclIndex help/*.html help/index.toc help/images/*.gif; \ + for i in *.tcl images/*.gif images2/*.gif images/icons.txt images2/icons.txt tclIndex help/*.html help/index.toc help/trace/*.html help/trace/index.toc help/images/*.gif; \ do \ $(INSTALL_DATA) $$i $(datadir)/gdbtcl/$$i ; \ done ; @@ -1174,12 +1175,24 @@ fork-child.o: fork-child.c $(wait_h) $(defs_h) $(gdbcore_h) \ gdbres.o: gdb.rc gdbtool.ico $(WINDRES) --include $(srcdir) $(srcdir)/gdb.rc gdbres.o -gdbtk.o: gdbtk.c $(defs_h) $(symtab_h) $(inferior_h) $(command_h) \ +gdbtk.o: gdbtk.c gdbtk.h $(defs_h) $(symtab_h) $(inferior_h) $(command_h) \ $(bfd_h) symfile.h objfiles.h target.h gdb_string.h $(tracepoint_h) $(CC) -c $(INTERNAL_CFLAGS) $(IDE_CFLAGS) $(ITCL_CFLAGS) $(TIX_CFLAGS) \ $(TCL_CFLAGS) $(TK_CFLAGS) $(X11_CFLAGS) \ $(srcdir)/gdbtk.c -DGDBTK_LIBRARY=\"$(datadir)/gdbtcl\" +gdbtk_cmds.o: gdbtk_cmds.c gdbtk.h $(defs_h) $(symtab_h) $(inferior_h) $(command_h) \ + $(bfd_h) symfile.h objfiles.h target.h gdb_string.h $(tracepoint_h) + $(CC) -c $(INTERNAL_CFLAGS) $(IDE_CFLAGS) $(ITCL_CFLAGS) $(TIX_CFLAGS) \ + $(TCL_CFLAGS) $(TK_CFLAGS) $(X11_CFLAGS) \ + $(srcdir)/gdbtk_cmds.c -DGDBTK_LIBRARY=\"$(datadir)/gdbtcl\" + +gdbtk_hooks.o: gdbtk_hooks.c gdbtk.h $(defs_h) $(symtab_h) $(inferior_h) $(command_h) \ + $(bfd_h) symfile.h objfiles.h target.h gdb_string.h $(tracepoint_h) + $(CC) -c $(INTERNAL_CFLAGS) $(IDE_CFLAGS) $(ITCL_CFLAGS) $(TIX_CFLAGS) \ + $(TCL_CFLAGS) $(TK_CFLAGS) $(X11_CFLAGS) \ + $(srcdir)/gdbtk_hooks.c -DGDBTK_LIBRARY=\"$(datadir)/gdbtcl\" + tracepoint.o: tracepoint.c $(defs_h) $(symtab_h) $(frame_h) $(tracepoint_h) \ $(gdbtypes_h) $(expression_h) $(gdbcmd_h) $(value_h) target.h \ language.h gdb_string.h $(readline_headers) diff --git a/gdb/configure b/gdb/configure index 4e6c3e9..cc33288 100755 --- a/gdb/configure +++ b/gdb/configure @@ -5213,7 +5213,7 @@ fi # were in LIBS then any link tests after this point would # try to include things like `$(LIBGUI)', which wouldn't work. GDBTKLIBS="${TCL_LIBS} ${TK_LIBS}" - CONFIG_OBS="${CONFIG_OBS} gdbtk.o" + CONFIG_OBS="${CONFIG_OBS} gdbtk.o gdbtk_cmds.o gdbtk_hooks.o" if test x$gdb_cv_os_cygwin32 = xyes; then WIN32LIBS="${WIN32LIBS} -lshell32 -lgdi32 -lcomdlg32 -ladvapi32 -luser32" diff --git a/gdb/configure.in b/gdb/configure.in index 1bcfc6a..d2ababd 100644 --- a/gdb/configure.in +++ b/gdb/configure.in @@ -425,7 +425,7 @@ if test "${enable_gdbtk}" = "yes"; then # were in LIBS then any link tests after this point would # try to include things like `$(LIBGUI)', which wouldn't work. GDBTKLIBS="${TCL_LIBS} ${TK_LIBS}" - CONFIG_OBS="${CONFIG_OBS} gdbtk.o" + CONFIG_OBS="${CONFIG_OBS} gdbtk.o gdbtk_cmds.o gdbtk_hooks.o" if test x$gdb_cv_os_cygwin32 = xyes; then WIN32LIBS="${WIN32LIBS} -lshell32 -lgdi32 -lcomdlg32 -ladvapi32 -luser32" diff --git a/gdb/gdbtk.c b/gdb/gdbtk.c index 1b2bf87..22057df 100644 --- a/gdb/gdbtk.c +++ b/gdb/gdbtk.c @@ -1,4 +1,4 @@ -/* Tcl/Tk interface routines. +/* Startup code for gdbtk. Copyright 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc. Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support. @@ -42,6 +42,7 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include <itcl.h> #include <tix.h> #include "guitcl.h" +#include "gdbtk.h" #ifdef IDE /* start-sanitize-ide */ @@ -70,143 +71,54 @@ Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */ #include "annotate.h" #include <sys/time.h> -#ifdef WINNT -#define GDBTK_PATH_SEP ";" -#else -#define GDBTK_PATH_SEP ":" -#endif - -/* Some versions (1.3.79, 1.3.81) of Linux don't support SIOCSPGRP the way - gdbtk wants to use it... */ -#ifdef __linux__ -#undef SIOCSPGRP -#endif +/* For Cygwin32, we use a timer to periodically check for Windows + messages. FIXME: It would be better to not poll, but to instead + rewrite the target_wait routines to serve as input sources. + Unfortunately, that will be a lot of work. */ +static sigset_t nullsigmask; +static struct sigaction act1, act2; +static struct itimerval it_on, it_off; extern int Tktable_Init PARAMS ((Tcl_Interp *interp)); -static int No_Update = 0; -static int load_in_progress = 0; -static int in_fputs = 0; - -int gdbtk_load_hash PARAMS ((char *, unsigned long)); -int (*ui_load_progress_hook) PARAMS ((char *, unsigned long)); -void (*pre_add_symbol_hook) PARAMS ((char *)); -void (*post_add_symbol_hook) PARAMS ((void)); - -#ifdef __CYGWIN32__ -extern void (*ui_loop_hook) PARAMS ((int)); -#endif - -char * get_prompt PARAMS ((void)); - -int gdbtk_test PARAMS ((char *)); static void null_routine PARAMS ((int)); -static void gdbtk_flush PARAMS ((FILE *)); -static void gdbtk_fputs PARAMS ((const char *, FILE *)); -static int gdbtk_query PARAMS ((const char *, va_list)); -static void gdbtk_warning PARAMS ((const char *, va_list)); -static void gdbtk_ignorable_warning PARAMS ((const char *)); -static char *gdbtk_readline PARAMS ((char *)); static void gdbtk_init PARAMS ((char *)); -static void tk_command_loop PARAMS ((void)); -static void gdbtk_call_command PARAMS ((struct cmd_list_element *, char *, int)); -static int gdbtk_wait PARAMS ((int, struct target_waitstatus *)); -static void x_event PARAMS ((int)); -static void gdbtk_interactive PARAMS ((void)); +void gdbtk_interactive PARAMS ((void)); static void cleanup_init PARAMS ((int)); static void tk_command PARAMS ((char *, int)); -static int gdb_disassemble PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static int compare_lines PARAMS ((const PTR, const PTR)); -static int gdbtk_dis_asm_read_memory PARAMS ((bfd_vma, bfd_byte *, int, disassemble_info *)); -static int gdb_path_conv PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static int gdb_stop PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static int gdb_confirm_quit PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static int gdb_force_quit PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static int gdb_listfiles PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[])); -static int gdb_listfuncs PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static int call_wrapper PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static int call_obj_wrapper PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST [])); -static int gdb_cmd PARAMS ((ClientData, Tcl_Interp *, int, char *argv[])); -static int gdb_immediate_command PARAMS ((ClientData, Tcl_Interp *, int, char *argv[])); -static int gdb_fetch_registers PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static void gdbtk_readline_end PARAMS ((void)); -static void pc_changed PARAMS ((void)); -static int gdb_changed_register_list PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static void register_changed_p PARAMS ((int, void *)); -static int gdb_get_breakpoint_list PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static int gdb_get_breakpoint_info PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static void breakpoint_notify PARAMS ((struct breakpoint *, const char *)); -static void gdbtk_create_breakpoint PARAMS ((struct breakpoint *)); -static void gdbtk_delete_breakpoint PARAMS ((struct breakpoint *)); -static void gdbtk_modify_breakpoint PARAMS ((struct breakpoint *)); -static int gdb_loc PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static int gdb_eval PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static int map_arg_registers PARAMS ((int, char *[], void (*) (int, void *), void *)); -static void get_register_name PARAMS ((int, void *)); -static int gdb_regnames PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static void get_register PARAMS ((int, void *)); -static int gdb_trace_status PARAMS ((ClientData, Tcl_Interp *, int, char *argv[])); -static int gdb_target_has_execution_command PARAMS ((ClientData, Tcl_Interp *, int, char *argv[])); -static int gdb_load_info PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[])); -void TclDebug PARAMS ((const char *fmt, ...)); -static int gdb_get_locals_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST - objv[])); -static int gdb_get_args_command 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_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_file_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[])); -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 gdb_actions_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[])); -static int gdb_prompt_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[])); -static int gdb_find_file_command 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 void gdbtk_create_tracepoint PARAMS ((struct tracepoint *)); -static void gdbtk_delete_tracepoint PARAMS ((struct tracepoint *)); -static void gdbtk_modify_tracepoint PARAMS ((struct tracepoint *)); -static void tracepoint_notify PARAMS ((struct tracepoint *, const char *)); -static void gdbtk_print_frame_info PARAMS ((struct symtab *, int, int, int)); -void gdbtk_pre_add_symbol PARAMS ((char *)); -void gdbtk_post_add_symbol PARAMS ((void)); -static int get_pc_register PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static int gdb_loadfile PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[])); -static int gdb_set_bp PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[])); -static struct symtab *full_lookup_symtab PARAMS ((char *file)); -static int gdb_get_mem PARAMS ((ClientData, Tcl_Interp *, int, char *[])); -static int gdb_search PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[])); -static int gdb_get_trace_frame_num PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[])); + +int gdbtk_test PARAMS ((char *)); + +/* + * gdbtk_fputs is defined in the gdbtk_hooks.c, but we need it here + * because we delay adding this hook till all the setup is done. That + * way errors will go to stdout. + */ + +extern void gdbtk_fputs PARAMS ((const char *, FILE *)); /* Handle for TCL interpreter */ Tcl_Interp *gdbtk_interp = NULL; static int gdbtk_timer_going = 0; -static void gdbtk_start_timer PARAMS ((void)); -static void gdbtk_stop_timer PARAMS ((void)); -/* This variable is true when the inferior is running. Although it's - possible to disable most input from widgets and thus prevent - attempts to do anything while the inferior is running, any commands - that get through - even a simple memory read - are Very Bad, and - may cause GDB to crash or behave strangely. So, this variable - provides an extra layer of defense. */ +/* This variable is true when the inferior is running. See note in + * gdbtk.h for details. + */ -static int running_now; +int running_now; /* This variable determines where memory used for disassembly is read from. - If > 0, then disassembly comes from the exec file rather than the - target (which might be at the other end of a slow serial link). If - == 0 then disassembly comes from target. If < 0 disassembly is - automatically switched to the target if it's an inferior process, - otherwise the exec file is used. */ + * See note in gdbtk.h for details. + */ -static int disassemble_from_exec = -1; +int disassemble_from_exec = -1; /* This variable holds the name of a Tcl file which should be sourced by the interpreter when it goes idle at startup. Used with the testsuite. */ -static char *gdbtk_source_filename = NULL; +static char *gdbtk_source_filename = NULL; + #ifndef _WIN32 /* Supply malloc calls for tcl/tk. We do not want to do this on @@ -246,12 +158,13 @@ null_routine(arg) #ifdef _WIN32 /* On Windows, if we hold a file open, other programs can't write to - it. In particular, we don't want to hold the executable open, - because it will mean that people have to get out of the debugging - session in order to remake their program. So we close it, although - this will cost us if and when we need to reopen it. */ + * it. In particular, we don't want to hold the executable open, + * because it will mean that people have to get out of the debugging + * session in order to remake their program. So we close it, although + * this will cost us if and when we need to reopen it. + */ -static void +void close_bfds () { struct objfile *o; @@ -268,1631 +181,52 @@ close_bfds () #endif /* _WIN32 */ -/* The following routines deal with stdout/stderr data, which is created by - {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the - lowest level of these routines and capture all output from the rest of GDB. - Normally they present their data to tcl via callbacks to the following tcl - routines: gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush. These - in turn call tk routines to update the display. - - Under some circumstances, you may want to collect the output so that it can - be returned as the value of a tcl procedure. This can be done by - surrounding the output routines with calls to start_saving_output and - finish_saving_output. The saved data can then be retrieved with - get_saved_output (but this must be done before the call to - finish_saving_output). */ - -/* Dynamic string for output. */ - -static Tcl_DString *result_ptr; - -/* Dynamic string for stderr. This is only used if result_ptr is - NULL. */ - -static Tcl_DString *error_string_ptr; -static void -gdbtk_flush (stream) - FILE *stream; -{ -#if 0 - /* Force immediate screen update */ - - Tcl_VarEval (gdbtk_interp, "gdbtk_tcl_flush", NULL); -#endif -} - -/* Print the string PTR, with necessary hair for dealing with the - GDB console thingy, etc. To wit: - - Append the string PTR to result_ptr or error_string_ptr, if they - are set. Otherwise, call the Tcl function `gdbtk_tcl_fputs', with - the string PTR as its only argument. */ -static void -gdbtk_fputs (ptr, stream) - const char *ptr; - FILE *stream; -{ - char *merge[2], *command; - in_fputs = 1; - - if (result_ptr) - Tcl_DStringAppend (result_ptr, (char *) ptr, -1); - else if (error_string_ptr != NULL && stream == gdb_stderr) - Tcl_DStringAppend (error_string_ptr, (char *) ptr, -1); - else - { - merge[0] = "gdbtk_tcl_fputs"; - merge[1] = (char *)ptr; - command = Tcl_Merge (2, merge); - Tcl_Eval (gdbtk_interp, command); - Tcl_Free (command); - } - in_fputs = 0; -} - -static void -gdbtk_warning (warning, args) - const char *warning; - va_list args; -{ - char buf[200], *merge[2]; - char *command; - - vsprintf (buf, warning, args); - merge[0] = "gdbtk_tcl_warning"; - merge[1] = buf; - command = Tcl_Merge (2, merge); - Tcl_Eval (gdbtk_interp, command); - Tcl_Free (command); -} - -static void -gdbtk_ignorable_warning (warning) - const char *warning; -{ - char buf[200], *merge[2]; - char *command; - - sprintf (buf, warning); - merge[0] = "gdbtk_tcl_ignorable_warning"; - merge[1] = buf; - command = Tcl_Merge (2, merge); - Tcl_Eval (gdbtk_interp, command); - Tcl_Free (command); -} - -static int -gdbtk_query (query, args) - const char *query; - va_list args; -{ - char buf[200], *merge[2]; - char *command; - long val; - - vsprintf (buf, query, args); - merge[0] = "gdbtk_tcl_query"; - merge[1] = buf; - command = Tcl_Merge (2, merge); - Tcl_Eval (gdbtk_interp, command); - Tcl_Free (command); - - val = atol (gdbtk_interp->result); - return val; -} - -/* VARARGS */ -static void -#ifdef ANSI_PROTOTYPES -gdbtk_readline_begin (char *format, ...) -#else -gdbtk_readline_begin (va_alist) - va_dcl -#endif -{ - va_list args; - char buf[200], *merge[2]; - char *command; - -#ifdef ANSI_PROTOTYPES - va_start (args, format); -#else - char *format; - va_start (args); - format = va_arg (args, char *); -#endif - - vsprintf (buf, format, args); - merge[0] = "gdbtk_tcl_readline_begin"; - merge[1] = buf; - command = Tcl_Merge (2, merge); - Tcl_Eval (gdbtk_interp, command); - Tcl_Free (command); -} - -static char * -gdbtk_readline (prompt) - char *prompt; -{ - char *merge[2]; - char *command; - int result; - -#ifdef _WIN32 - close_bfds (); -#endif - - merge[0] = "gdbtk_tcl_readline"; - merge[1] = prompt; - command = Tcl_Merge (2, merge); - result = Tcl_Eval (gdbtk_interp, command); - Tcl_Free (command); - if (result == TCL_OK) - { - return (strdup (gdbtk_interp -> result)); - } - else - { - gdbtk_fputs (gdbtk_interp -> result, gdb_stdout); - gdbtk_fputs ("\n", gdb_stdout); - return (NULL); - } -} - -static void -gdbtk_readline_end () -{ - Tcl_Eval (gdbtk_interp, "gdbtk_tcl_readline_end"); -} - -static void -pc_changed() -{ - Tcl_Eval (gdbtk_interp, "gdbtk_pc_changed"); -} +/* TclDebug (const char *fmt, ...) works just like printf() but + * sends the output to the GDB TK debug window. + * Not for normal use; just a convenient tool for debugging + */ - -static void +void #ifdef ANSI_PROTOTYPES -dsprintf_append_element (Tcl_DString *dsp, char *format, ...) +TclDebug (const char *fmt, ...) #else -dsprintf_append_element (va_alist) +TclDebug (va_alist) va_dcl #endif { va_list args; - char buf[1024]; + char buf[512], *v[2], *merge; #ifdef ANSI_PROTOTYPES - va_start (args, format); + va_start (args, fmt); #else - Tcl_DString *dsp; - char *format; - + char *fmt; va_start (args); - dsp = va_arg (args, Tcl_DString *); - format = va_arg (args, char *); -#endif - - vsprintf (buf, format, args); - - Tcl_DStringAppendElement (dsp, buf); -} - -static int -gdb_path_conv (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ -#ifdef WINNT - char pathname[256], *ptr; - if (argc != 2) - error ("wrong # args"); - cygwin32_conv_to_full_win32_path (argv[1], pathname); - for (ptr = pathname; *ptr; ptr++) - { - if (*ptr == '\\') - *ptr = '/'; - } -#else - char *pathname = argv[1]; -#endif - Tcl_DStringAppend (result_ptr, pathname, strlen(pathname)); - return TCL_OK; -} - -static int -gdb_get_breakpoint_list (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - struct breakpoint *b; - extern struct breakpoint *breakpoint_chain; - - if (argc != 1) - error ("wrong # args"); - - for (b = breakpoint_chain; b; b = b->next) - if (b->type == bp_breakpoint) - dsprintf_append_element (result_ptr, "%d", b->number); - - return TCL_OK; -} - -static int -gdb_get_breakpoint_info (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - struct symtab_and_line sal; - static 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" }; - static char *bpdisp[] = {"delete", "delstop", "disable", "donttouch"}; - struct command_line *cmd; - int bpnum; - struct breakpoint *b; - extern struct breakpoint *breakpoint_chain; - char *funcname, *fname, *filename; - - if (argc != 2) - error ("wrong # args"); - - bpnum = atoi (argv[1]); - - for (b = breakpoint_chain; b; b = b->next) - if (b->number == bpnum) - break; - - if (!b || b->type != bp_breakpoint) - error ("Breakpoint #%d does not exist", bpnum); - - sal = find_pc_line (b->address, 0); - - filename = symtab_to_filename (sal.symtab); - if (filename == NULL) - filename = ""; - Tcl_DStringAppendElement (result_ptr, filename); - - find_pc_partial_function (b->address, &funcname, NULL, NULL); - fname = cplus_demangle (funcname, 0); - if (fname) - { - Tcl_DStringAppendElement (result_ptr, fname); - free (fname); - } - else - Tcl_DStringAppendElement (result_ptr, funcname); - dsprintf_append_element (result_ptr, "%d", b->line_number); - dsprintf_append_element (result_ptr, "0x%lx", b->address); - Tcl_DStringAppendElement (result_ptr, bptypes[b->type]); - Tcl_DStringAppendElement (result_ptr, b->enable == enabled ? "1" : "0"); - Tcl_DStringAppendElement (result_ptr, bpdisp[b->disposition]); - dsprintf_append_element (result_ptr, "%d", b->ignore_count); - - Tcl_DStringStartSublist (result_ptr); - for (cmd = b->commands; cmd; cmd = cmd->next) - Tcl_DStringAppendElement (result_ptr, cmd->line); - Tcl_DStringEndSublist (result_ptr); - - Tcl_DStringAppendElement (result_ptr, b->cond_string); - - dsprintf_append_element (result_ptr, "%d", b->thread); - dsprintf_append_element (result_ptr, "%d", b->hit_count); - - return TCL_OK; -} - -static void -breakpoint_notify(b, action) - struct breakpoint *b; - const char *action; -{ - char buf[256]; - int v; - struct symtab_and_line sal; - char *filename; - - if (b->type != bp_breakpoint) - return; - - /* We ensure that ACTION contains no special Tcl characters, so we - can do this. */ - sal = find_pc_line (b->address, 0); - filename = symtab_to_filename (sal.symtab); - if (filename == NULL) - filename = ""; - - sprintf (buf, "gdbtk_tcl_breakpoint %s %d 0x%lx %d {%s}", action, b->number, - (long)b->address, b->line_number, filename); - - v = Tcl_Eval (gdbtk_interp, buf); - - if (v != TCL_OK) - { - gdbtk_fputs (gdbtk_interp->result, gdb_stdout); - gdbtk_fputs ("\n", gdb_stdout); - } -} - -static void -gdbtk_create_breakpoint(b) - struct breakpoint *b; -{ - breakpoint_notify (b, "create"); -} - -static void -gdbtk_delete_breakpoint(b) - struct breakpoint *b; -{ - breakpoint_notify (b, "delete"); -} - -static void -gdbtk_modify_breakpoint(b) - struct breakpoint *b; -{ - breakpoint_notify (b, "modify"); -} - -/* This implements the TCL command `gdb_loc', which returns a list */ -/* consisting of the following: */ -/* basename, function name, filename, line number, address, current pc */ - -static int -gdb_loc (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - char *filename; - struct symtab_and_line sal; - char *funcname, *fname; - CORE_ADDR pc; - - if (!have_full_symbols () && !have_partial_symbols ()) - { - Tcl_SetResult (interp, "No symbol table is loaded", TCL_STATIC); - return TCL_ERROR; - } - - if (argc == 1) - { - if (selected_frame && (selected_frame->pc != stop_pc)) - { - /* Note - this next line is not correct on all architectures. */ - /* For a graphical debugged 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 (argc == 2) - { - struct symtabs_and_lines sals; - int nelts; - - sals = decode_line_spec (argv[1], 1); - - nelts = sals.nelts; - sal = sals.sals[0]; - free (sals.sals); - - if (sals.nelts != 1) - error ("Ambiguous line spec"); - - pc = sal.pc; - } - else - error ("wrong # args"); - - if (sal.symtab) - Tcl_DStringAppendElement (result_ptr, sal.symtab->filename); - else - Tcl_DStringAppendElement (result_ptr, ""); - - find_pc_partial_function (pc, &funcname, NULL, NULL); - fname = cplus_demangle (funcname, 0); - if (fname) - { - Tcl_DStringAppendElement (result_ptr, fname); - free (fname); - } - else - Tcl_DStringAppendElement (result_ptr, funcname); - filename = symtab_to_filename (sal.symtab); - if (filename == NULL) - filename = ""; - - Tcl_DStringAppendElement (result_ptr, filename); - dsprintf_append_element (result_ptr, "%d", sal.line); /* line number */ - dsprintf_append_element (result_ptr, "0x%s", paddr_nz(pc)); /* PC in current frame */ - dsprintf_append_element (result_ptr, "0x%s", paddr_nz(stop_pc)); /* Real PC */ - return TCL_OK; -} - -/* This implements the TCL command `gdb_eval'. */ - -static int -gdb_eval (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - struct expression *expr; - struct cleanup *old_chain; - value_ptr val; - - if (argc != 2) - error ("wrong # args"); - - expr = parse_expression (argv[1]); - - old_chain = make_cleanup (free_current_contents, &expr); - - val = evaluate_expression (expr); - - val_print (VALUE_TYPE (val), VALUE_CONTENTS (val), VALUE_ADDRESS (val), - gdb_stdout, 0, 0, 0, 0); - - do_cleanups (old_chain); - - return TCL_OK; -} - -/* gdb_get_mem addr form size num aschar*/ -/* dump a block of memory */ -/* 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 */ -/* returns a list of elements followed by an optional */ -/* ASCII dump */ - -static int -gdb_get_mem (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - int size, asize, i, j, bc; - CORE_ADDR addr; - int nbytes, rnum, bpr; - char format, c, *ptr, buff[128], aschar, *mbuf, *mptr, *cptr, *bptr; - struct type *val_type; - - if (argc < 6 || argc > 7) - { - interp->result = "addr format size bytes bytes_per_row ?ascii_char?"; - return TCL_ERROR; - } - - size = (int)strtoul(argv[3],(char **)NULL,0); - nbytes = (int)strtoul(argv[4],(char **)NULL,0); - bpr = (int)strtoul(argv[5],(char **)NULL,0); - if (nbytes <= 0 || bpr <= 0 || size <= 0) - { - interp->result = "Invalid number of bytes."; - return TCL_ERROR; - } - - addr = (CORE_ADDR)strtoul(argv[1],(char **)NULL,0); - format = *argv[2]; - mbuf = (char *)malloc (nbytes+32); - if (!mbuf) - { - interp->result = "Out of memory."; - return TCL_ERROR; - } - memset (mbuf, 0, nbytes+32); - mptr = cptr = mbuf; - - rnum = target_read_memory_partial (addr, mbuf, nbytes, NULL); - - if (argv[6]) - aschar = *argv[6]; - 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 */ - - 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); - fputs_unfiltered (" ", 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]; - } - } - - free (mbuf); - return TCL_OK; -} - -static int -map_arg_registers (argc, argv, func, argp) - int argc; - char *argv[]; - void (*func) PARAMS ((int regnum, void *argp)); - void *argp; -{ - int regnum; - - /* Note that the test for a valid register must include checking the - reg_names array because NUM_REGS may be allocated for the union of the - register sets within a family of related processors. In this case, the - trailing entries of reg_names will change depending upon the particular - processor being debugged. */ - - if (argc == 0) /* No args, just do all the regs */ - { - for (regnum = 0; - regnum < NUM_REGS - && reg_names[regnum] != NULL - && *reg_names[regnum] != '\000'; - regnum++) - func (regnum, argp); - - return TCL_OK; - } - - /* Else, list of register #s, just do listed regs */ - for (; argc > 0; argc--, argv++) - { - regnum = atoi (*argv); - - if (regnum >= 0 - && regnum < NUM_REGS - && reg_names[regnum] != NULL - && *reg_names[regnum] != '\000') - func (regnum, argp); - else - error ("bad register number"); - } - - return TCL_OK; -} - -static void -get_register_name (regnum, argp) - int regnum; - void *argp; /* Ignored */ -{ - Tcl_DStringAppendElement (result_ptr, reg_names[regnum]); -} - -/* This implements the TCL command `gdb_regnames', which returns a list of - all of the register names. */ - -static int -gdb_regnames (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - argc--; - argv++; - - return map_arg_registers (argc, argv, get_register_name, NULL); -} - -#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) + fmt = va_arg (args, char *); #endif -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; - - if (format == 'N') - format = 0; - - if (read_relative_register_raw_bytes (regnum, raw_buffer)) - { - Tcl_DStringAppendElement (result_ptr, "Optimized out"); - 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, - gdb_stdout, format, 1, 0, Val_pretty_default); - - Tcl_DStringAppend (result_ptr, " ", -1); -} - -static int -get_pc_register (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - sprintf(interp->result,"0x%llx",(long long)read_register(PC_REGNUM)); - return TCL_OK; -} - -static int -gdb_fetch_registers (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - int format; - - if (argc < 2) - error ("wrong # args"); - - argc -= 2; - argv++; - format = **argv++; - - return map_arg_registers (argc, argv, get_register, (void *) format); -} - -/* This contains the previous values of the registers, since the last call to - gdb_changed_register_list. */ - -static char old_regs[REGISTER_BYTES]; - -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)); - - dsprintf_append_element (result_ptr, "%d", regnum); -} - -static int -gdb_changed_register_list (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - argc--; - argv++; - - return map_arg_registers (argc, argv, register_changed_p, NULL); -} - -/* This implements the tcl command "gdb_immediate", which 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. */ -static int -gdb_immediate_command (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - Tcl_DString *save_ptr = NULL; - - if (argc != 2) - error ("wrong # args"); - - if (running_now || load_in_progress) - return TCL_OK; - - No_Update = 0; - - Tcl_DStringAppend (result_ptr, "", -1); - save_ptr = result_ptr; - result_ptr = NULL; - - execute_command (argv[1], 1); - - bpstat_do_actions (&stop_bpstat); - - result_ptr = save_ptr; - - return TCL_OK; -} - -/* This implements the TCL command `gdb_cmd', which sends its argument into - the GDB command scanner. */ -/* This command will never cause the update, idle and busy hooks to be called - within the GUI. */ -static int -gdb_cmd (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - Tcl_DString *save_ptr = NULL; - - if (argc < 2) - error ("wrong # args"); - - if (running_now || load_in_progress) - return TCL_OK; - - No_Update = 1; - - /* for the load instruction (and possibly others later) we - set result_ptr to NULL so gdbtk_fputs() will not buffer - all the data until the command is finished. */ - - if (strncmp ("load ", argv[1], 5) == 0 - || strncmp ("while ", argv[1], 6) == 0) - { - Tcl_DStringAppend (result_ptr, "", -1); - save_ptr = result_ptr; - result_ptr = NULL; - load_in_progress = 1; - gdbtk_start_timer (); - } - - execute_command (argv[1], 1); - - if (load_in_progress) - { - gdbtk_stop_timer (); - load_in_progress = 0; - } - - bpstat_do_actions (&stop_bpstat); - - if (save_ptr) - result_ptr = save_ptr; - - return TCL_OK; -} - -/* Client of call_wrapper - this routine performs the actual call to - the client function. */ - -struct wrapped_call_args -{ - Tcl_Interp *interp; - Tcl_CmdProc *func; - int argc; - char **argv; - int val; -}; - -static int -wrapped_call (args) - struct wrapped_call_args *args; -{ - args->val = (*args->func) (args->func, args->interp, args->argc, args->argv); - return 1; -} - -struct wrapped_call_objs -{ - Tcl_Interp *interp; - Tcl_ObjCmdProc *func; - int objc; - Tcl_Obj * CONST *objv; - int val; -}; - -static int -wrapped_obj_call (args) - struct wrapped_call_objs *args; -{ - args->val = (*args->func) (args->func, args->interp, args->objc, args->objv); - return 1; -} - -/* This routine acts as a top-level for all GDB code called by tcl/Tk. It - handles cleanups, and 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 jmp_buf as - necessary. */ - -static int -call_wrapper (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - struct wrapped_call_args wrapped_args; - Tcl_DString result, *old_result_ptr; - Tcl_DString error_string, *old_error_string_ptr; - - Tcl_DStringInit (&result); - old_result_ptr = result_ptr; - result_ptr = &result; - - Tcl_DStringInit (&error_string); - old_error_string_ptr = error_string_ptr; - error_string_ptr = &error_string; - - wrapped_args.func = (Tcl_CmdProc *)clientData; - wrapped_args.interp = interp; - wrapped_args.argc = argc; - wrapped_args.argv = argv; - wrapped_args.val = 0; - - 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. */ - if (gdbtk_timer_going) - gdbtk_stop_timer (); - - 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; - - if (Tcl_DStringLength (&error_string) == 0) - { - Tcl_DStringResult (interp, &result); - Tcl_DStringFree (&error_string); - } - else if (Tcl_DStringLength (&result) == 0) - { - Tcl_DStringResult (interp, &error_string); - Tcl_DStringFree (&result); - Tcl_DStringFree (&error_string); - } - else - { - Tcl_ResetResult (interp); - Tcl_AppendResult (interp, Tcl_DStringValue (&result), - Tcl_DStringValue (&error_string), (char *) NULL); - Tcl_DStringFree (&result); - Tcl_DStringFree (&error_string); - } - - result_ptr = old_result_ptr; - error_string_ptr = old_error_string_ptr; + v[0] = "debug"; + v[1] = buf; -#ifdef _WIN32 - close_bfds (); -#endif + vsprintf (buf, fmt, args); + va_end (args); - return wrapped_args.val; + merge = Tcl_Merge (2, v); + Tcl_Eval (gdbtk_interp, merge); + Tcl_Free (merge); } -static int -call_obj_wrapper (clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - struct wrapped_call_objs wrapped_args; - Tcl_DString result, *old_result_ptr; - Tcl_DString error_string, *old_error_string_ptr; - - /* The obj call wrapper works differently from the string wrapper, because - * the obj calls currently insert their results directly into the - * interpreter's result. So there is no need to have a result_ptr... - * FIXME - rewrite all the object commands so they use a result_obj_ptr - * - rewrite all the string commands to be object commands. - */ - - Tcl_DStringInit (&result); - old_result_ptr = result_ptr; - result_ptr = &result; - - Tcl_DStringInit (&error_string); - - Tcl_DStringInit (&error_string); - old_error_string_ptr = error_string_ptr; - error_string_ptr = &error_string; - wrapped_args.func = (Tcl_ObjCmdProc *)clientData; - wrapped_args.interp = interp; - wrapped_args.objc = objc; - wrapped_args.objv = objv; - wrapped_args.val = 0; - - if (!catch_errors (wrapped_obj_call, &wrapped_args, "", RETURN_MASK_ALL)) - { - wrapped_args.val = TCL_ERROR; /* Flag an error for TCL */ - - /* Make sure the timer interrupts are turned off. */ - if (gdbtk_timer_going) - gdbtk_stop_timer (); - - 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"); - /* if the error message is in RESULT instead of ERROR_STRING we copy it - back to ERROR_STRING and free RESULT */ + +/* + * The rest of this file contains the start-up, and event handling code for gdbtk. + */ + +/* + * This cleanup function is added to the cleanup list that surrounds the Tk + * main in gdbtk_init. It deletes the Tcl interpreter. + */ - if ((Tcl_DStringLength (&error_string) == 0) && - (Tcl_DStringLength (&result) > 0)) - { - Tcl_DStringAppend (&error_string, Tcl_DStringValue (&result), - Tcl_DStringLength (&result)); - Tcl_DStringFree (&result); - } - } - - /* do not suppress any errors -- a remote target could have errored */ - load_in_progress = 0; - - if (Tcl_DStringLength (&error_string) == 0) - { - /* We should insert the result here, but the obj commands now - * do this directly, so we don't need to. - * FIXME - ultimately, all this should be redone so that all the - * commands either manipulate the Tcl result directly, or use a result_ptr. - */ - - Tcl_DStringFree (&error_string); - } - else if (*(Tcl_GetStringResult (interp)) == '\0') - { - Tcl_DStringResult (interp, &error_string); - Tcl_DStringFree (&error_string); - } - else - { - Tcl_AppendToObj(Tcl_GetObjResult(interp), Tcl_DStringValue (&error_string), - Tcl_DStringLength (&error_string)); - Tcl_DStringFree (&error_string); - } - - result_ptr = old_result_ptr; - error_string_ptr = old_error_string_ptr; - -#ifdef _WIN32 - close_bfds (); -#endif - - return wrapped_args.val; -} - -static int -comp_files (file1, file2) - const char *file1[], *file2[]; -{ - return strcmp(*file1,*file2); -} - -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, **files; - int files_size; - int i, numfiles = 0, len = 0; - Tcl_Obj *mylist; - - 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); - - mylist = Tcl_NewListObj (0, NULL); - - ALL_PSYMTABS (objfile, psymtab) - { - if (numfiles == files_size) - { - files_size = files_size * 2; - files = (char **) xrealloc (files, sizeof (char *) * files_size); - } - if (len == 0) - { - if (psymtab->filename) - files[numfiles++] = basename(psymtab->filename); - } - else if (!strcmp(psymtab->filename,basename(psymtab->filename)) - || !strncmp(pathname,psymtab->filename,len)) - if (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 (len == 0) - { - if (symtab->filename) - files[numfiles++] = basename(symtab->filename); - } - else if (!strcmp(symtab->filename,basename(symtab->filename)) - || !strncmp(pathname,symtab->filename,len)) - if (symtab->filename) - files[numfiles++] = basename(symtab->filename); - } - - qsort (files, numfiles, sizeof(char *), comp_files); - - lastfile = ""; - for (i = 0; i < numfiles; i++) - { - if (strcmp(files[i],lastfile)) - Tcl_ListObjAppendElement (interp, mylist, Tcl_NewStringObj(files[i], -1)); - lastfile = files[i]; - } - Tcl_SetObjResult (interp, mylist); - free (files); - return TCL_OK; -} - -static int -gdb_listfuncs (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - struct symtab *symtab; - struct blockvector *bv; - struct block *b; - struct symbol *sym; - char buf[128]; - int i,j; - - if (argc != 2) - error ("wrong # args"); - - symtab = full_lookup_symtab (argv[1]); - if (!symtab) - error ("No such file"); - - 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) - { - sprintf (buf,"{%s} 1", name); - } - else - sprintf (buf,"{%s} 0", SYMBOL_NAME(sym)); - Tcl_DStringAppendElement (result_ptr, buf); - } - } - } - return TCL_OK; -} - -static int -target_stop_wrapper (args) - char * args; -{ - target_stop (); - return 1; -} - -static int -gdb_stop (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - if (target_stop) - { - catch_errors (target_stop_wrapper, NULL, "", - RETURN_MASK_ALL); - } - else - quit_flag = 1; /* hope something sees this */ - - return TCL_OK; -} - -/* 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. */ - -static int -gdb_clear_file (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - 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; -} - -/* Ask the user to confirm an exit request. */ - -static int -gdb_confirm_quit (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - int ret; - - ret = quit_confirm (); - Tcl_DStringAppendElement (result_ptr, ret ? "1" : "0"); - return TCL_OK; -} - -/* Quit without asking for confirmation. */ - -static int -gdb_force_quit (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - quit_force ((char *) NULL, 1); - return TCL_OK; -} - -/* This implements the TCL command `gdb_disassemble'. */ - -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; -} - -/* 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. This is because of the - reordering we are about to do. */ - -struct my_line_entry { - int line; - CORE_ADDR start_pc; - CORE_ADDR end_pc; -}; - -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; -} - -static int -gdb_disassemble (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - CORE_ADDR pc, low, high; - int mixed_source_and_assembly; - static disassemble_info di; - static int di_initialized; - - if (! di_initialized) - { - INIT_DISASSEMBLE_INFO_NO_ARCH (di, gdb_stdout, - (fprintf_ftype) fprintf_unfiltered); - di.flavour = bfd_target_unknown_flavour; - di.memory_error_func = dis_asm_memory_error; - di.print_address_func = dis_asm_print_address; - di_initialized = 1; - } - - di.mach = tm_print_insn_info.mach; - if (TARGET_BYTE_ORDER == BIG_ENDIAN) - di.endian = BFD_ENDIAN_BIG; - else - di.endian = BFD_ENDIAN_LITTLE; - - if (argc != 3 && argc != 4) - error ("wrong # args"); - - if (strcmp (argv[1], "source") == 0) - mixed_source_and_assembly = 1; - else if (strcmp (argv[1], "nosource") == 0) - mixed_source_and_assembly = 0; - else - error ("First arg must be 'source' or 'nosource'"); - - low = parse_and_eval_address (argv[2]); - - if (argc == 3) - { - if (find_pc_partial_function (low, NULL, &low, &high) == 0) - error ("No function contains specified address"); - } - else - high = parse_and_eval_address (argv[3]); - - /* 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) - 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; -} - -static void -tk_command (cmd, from_tty) - char *cmd; - int from_tty; -{ - int retval; - char *result; - struct cleanup *old_chain; - - /* Catch case of no argument, since this will make the tcl interpreter dump core. */ - if (cmd == NULL) - error_no_arg ("tcl command to interpret"); - - retval = Tcl_Eval (gdbtk_interp, cmd); - - result = strdup (gdbtk_interp->result); - - old_chain = make_cleanup (free, result); - - if (retval != TCL_OK) - error (result); - - printf_unfiltered ("%s\n", result); - - do_cleanups (old_chain); -} - static void cleanup_init (ignored) int ignored; @@ -1905,66 +239,14 @@ cleanup_init (ignored) /* Come here during long calculations to check for GUI events. Usually invoked via the QUIT macro. */ -static void +void gdbtk_interactive () { /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */ } -/* Come here when there is activity on the X file descriptor. */ - -static void -x_event (signo) - int signo; -{ - static int in_x_event = 0; - static Tcl_Obj *varname = NULL; - if (in_x_event || in_fputs) - return; - - in_x_event = 1; - -#ifdef __CYGWIN32__ - if (signo == -2) - if (gdbtk_timer_going) - gdbtk_stop_timer (); -#endif - - /* Process pending events */ - while (Tcl_DoOneEvent (TCL_DONT_WAIT|TCL_ALL_EVENTS) != 0) - ; - - if (load_in_progress) - { - int val; - if (varname == NULL) - { - Tcl_Obj *varnamestrobj = Tcl_NewStringObj ("download_cancel_ok",-1); - varname = Tcl_ObjGetVar2 (gdbtk_interp,varnamestrobj,NULL,TCL_GLOBAL_ONLY); - } - if ((Tcl_GetIntFromObj (gdbtk_interp,varname,&val) == TCL_OK) && val) - { - quit_flag = 1; -#ifdef REQUEST_QUIT - REQUEST_QUIT; -#else - if (immediate_quit) - quit (); -#endif - } - } - in_x_event = 0; -} - -/* For Cygwin32, we use a timer to periodically check for Windows - messages. FIXME: It would be better to not poll, but to instead - rewrite the target_wait routines to serve as input sources. - Unfortunately, that will be a lot of work. */ -static sigset_t nullsigmask; -static struct sigaction act1, act2; -static struct itimerval it_on, it_off; -static void +void gdbtk_start_timer () { static int first = 1; @@ -2002,7 +284,7 @@ gdbtk_start_timer () } } -static void +void gdbtk_stop_timer () { if (gdbtk_timer_going) @@ -2014,20 +296,6 @@ gdbtk_stop_timer () } } -/* This hook function is called whenever we want to wait for the - target. */ - -static int -gdbtk_wait (pid, ourstatus) - int pid; - struct target_waitstatus *ourstatus; -{ - gdbtk_start_timer (); - pid = target_wait (pid, ourstatus); - gdbtk_stop_timer (); - return pid; -} - /* This is called from execute_command, and provides a wrapper around various command routines in a place where both protocol messages and user input both flow through. Mostly this is used for indicating whether @@ -2077,39 +345,6 @@ gdbtk_call_command (cmdblk, arg, from_tty) (*cmdblk->function.cfunc)(arg, from_tty); } -/* This function is called instead of gdb's internal command loop. This is the - last chance to do anything before entering the main Tk event loop. */ - -static void -tk_command_loop () -{ - extern GDB_FILE *instream; - - /* We no longer want to use stdin as the command input stream */ - instream = NULL; - - if (Tcl_Eval (gdbtk_interp, "gdbtk_tcl_preloop") != TCL_OK) - { - char *msg; - - /* Force errorInfo to be set up propertly. */ - Tcl_AddErrorInfo (gdbtk_interp, ""); - - msg = Tcl_GetVar (gdbtk_interp, "errorInfo", TCL_GLOBAL_ONLY); -#ifdef _WIN32 - MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL); -#else - fputs_unfiltered (msg, gdb_stderr); -#endif - } - -#ifdef _WIN32 - close_bfds (); -#endif - - Tk_MainLoop (); -} - /* gdbtk_init installs this function as a final cleanup. */ static void @@ -2124,7 +359,12 @@ gdbtk_cleanup (dummy) Tcl_Finalize (); } -/* Initialize gdbtk. */ +/* Initialize gdbtk. This involves creating a Tcl interpreter, + * defining all the Tcl commands that the GUI will use, pointing + * all the gdb "hooks" to the correct functions, + * and setting the Tcl auto loading environment so that we can find all + * the Tcl based library files. + */ static void gdbtk_init ( argv0 ) @@ -2162,7 +402,7 @@ gdbtk_init ( argv0 ) gdbtk_interp = Tcl_CreateInterp (); #ifdef TCL_MEM_DEBUG - Tcl_InitMemory (interp); + Tcl_InitMemory (gdbtk_interp); #endif if (!gdbtk_interp) @@ -2248,14 +488,22 @@ gdbtk_init ( argv0 ) if (Itcl_Init(gdbtk_interp) == TCL_ERROR) error ("Itcl_Init failed: %s", gdbtk_interp->result); + Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init, + (Tcl_PackageInitProc *) NULL); if (Tix_Init(gdbtk_interp) != TCL_OK) error ("Tix_Init failed: %s", gdbtk_interp->result); + Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init, + (Tcl_PackageInitProc *) NULL); if (Tktable_Init(gdbtk_interp) != TCL_OK) error ("Tktable_Init failed: %s", gdbtk_interp->result); + Tcl_StaticPackage(gdbtk_interp, "Tktable", Tktable_Init, (Tcl_PackageInitProc *) NULL); + /* + * These are the commands to do some Windows Specific stuff... + */ #ifdef __CYGWIN32__ if (ide_create_messagebox_command (gdbtk_interp) != TCL_OK) @@ -2277,100 +525,29 @@ gdbtk_init ( argv0 ) error ("cygwin path command initialization failed"); #endif - Tcl_CreateCommand (gdbtk_interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_immediate", call_wrapper, - gdb_immediate_command, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_loc", call_wrapper, gdb_loc, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_path_conv", call_wrapper, gdb_path_conv, NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_listfiles", call_obj_wrapper, gdb_listfiles, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_listfuncs", call_wrapper, gdb_listfuncs, - NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_get_mem", call_wrapper, gdb_get_mem, - NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_stop", call_wrapper, gdb_stop, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_fetch_registers", call_wrapper, - gdb_fetch_registers, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_changed_register_list", call_wrapper, - gdb_changed_register_list, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_disassemble", call_wrapper, - gdb_disassemble, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_eval", call_wrapper, gdb_eval, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_get_breakpoint_list", call_wrapper, - gdb_get_breakpoint_list, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_get_breakpoint_info", call_wrapper, - gdb_get_breakpoint_info, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_clear_file", call_wrapper, - gdb_clear_file, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_confirm_quit", call_wrapper, - gdb_confirm_quit, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_force_quit", call_wrapper, - gdb_force_quit, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_target_has_execution", - gdb_target_has_execution_command, - NULL, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_is_tracing", - gdb_trace_status, - NULL, NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_load_info", call_obj_wrapper, gdb_load_info, NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_get_locals", call_obj_wrapper, gdb_get_locals_command, - NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_get_args", call_obj_wrapper, gdb_get_args_command, - NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_get_function", call_obj_wrapper, gdb_get_function_command, - NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_get_line", call_obj_wrapper, gdb_get_line_command, - NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_get_file", call_obj_wrapper, gdb_get_file_command, - NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_tracepoint_exists", - call_obj_wrapper, gdb_tracepoint_exists_command, NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_get_tracepoint_info", - call_obj_wrapper, gdb_get_tracepoint_info, NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_actions", - call_obj_wrapper, gdb_actions_command, NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_prompt", - call_obj_wrapper, gdb_prompt_command, NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_find_file", - call_obj_wrapper, gdb_find_file_command, NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_get_tracepoint_list", - call_obj_wrapper, gdb_get_tracepoint_list, NULL); - Tcl_CreateCommand (gdbtk_interp, "gdb_pc_reg", get_pc_register, NULL, NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_loadfile", call_obj_wrapper, gdb_loadfile, NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_set_bp", call_obj_wrapper, gdb_set_bp, NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_search", call_obj_wrapper, gdb_search, NULL); - Tcl_CreateObjCommand (gdbtk_interp, "gdb_get_trace_frame_num", - call_obj_wrapper, gdb_get_trace_frame_num, NULL); - - command_loop_hook = tk_command_loop; - print_frame_info_listing_hook = gdbtk_print_frame_info; - query_hook = gdbtk_query; - warning_hook = gdbtk_warning; - flush_hook = gdbtk_flush; - create_breakpoint_hook = gdbtk_create_breakpoint; - delete_breakpoint_hook = gdbtk_delete_breakpoint; - modify_breakpoint_hook = gdbtk_modify_breakpoint; - interactive_hook = gdbtk_interactive; - target_wait_hook = gdbtk_wait; - call_command_hook = gdbtk_call_command; - readline_begin_hook = gdbtk_readline_begin; - readline_hook = gdbtk_readline; - readline_end_hook = gdbtk_readline_end; - ui_load_progress_hook = gdbtk_load_hash; -#ifdef __CYGWIN32__ - ui_loop_hook = x_event; -#endif - pre_add_symbol_hook = gdbtk_pre_add_symbol; - post_add_symbol_hook = gdbtk_post_add_symbol; - create_tracepoint_hook = gdbtk_create_tracepoint; - delete_tracepoint_hook = gdbtk_delete_tracepoint; - modify_tracepoint_hook = gdbtk_modify_tracepoint; - pc_changed_hook = pc_changed; + /* + * This adds all the Gdbtk commands. + */ + + if (Gdbtk_Init(gdbtk_interp) != TCL_OK) + { + error("Gdbtk_Init failed: %s", gdbtk_interp->result); + } + + Tcl_StaticPackage(gdbtk_interp, "Gdbtk", Gdbtk_Init, NULL); + + /* This adds all the hooks that call up from the bowels of gdb + * back into Tcl-land... + */ + + gdbtk_add_hooks(); + + /* Add a back door to Tk from the gdb console... */ add_com ("tk", class_obscure, tk_command, "Send a command directly into tk."); - Tcl_LinkVar (gdbtk_interp, "disassemble-from-exec", (char *)&disassemble_from_exec, + Tcl_LinkVar (gdbtk_interp, "disassemble-from-exec", (char *) &disassemble_from_exec, TCL_LINK_INT); /* find the gdb tcl library and source main.tcl */ @@ -2387,14 +564,14 @@ gdbtk_init ( argv0 ) found_main = 0; /* see if GDBTK_LIBRARY is a path list */ lib = strtok (gdbtk_lib_tmp, GDBTK_PATH_SEP); - auto_path_elem = Tcl_NewObj (); + auto_path_name = Tcl_NewStringObj ("auto_path", -1); do { - Tcl_SetStringObj (auto_path_elem, lib, -1); + auto_path_elem = Tcl_NewStringObj (lib, -1); if (Tcl_ObjSetVar2 (gdbtk_interp, auto_path_name, NULL, auto_path_elem, - TCL_GLOBAL_ONLY | TCL_LIST_ELEMENT ) == NULL) + TCL_GLOBAL_ONLY | TCL_APPEND_VALUE | TCL_LIST_ELEMENT ) == NULL) { fputs_unfiltered (Tcl_GetVar (gdbtk_interp, "errorInfo", 0), gdb_stderr); error (""); @@ -2412,9 +589,8 @@ gdbtk_init ( argv0 ) while ((lib = strtok (NULL, ":")) != NULL); free (gdbtk_lib_tmp); - Tcl_DecrRefCount(auto_path_elem); Tcl_DecrRefCount(auto_path_name); - + if (!found_main) { /* Try finding it with the auto path. */ @@ -2475,7 +651,7 @@ gdbtk_find_main"; Tcl_DStringInit (&source_cmd); Tcl_DStringAppend (&source_cmd, - "if {[info exists env(TCLPRO_DEBUG_DIR)]} {source [file join $env(TCLPRO_DEBUG_DIR) src loader.tcl];", -1); + "if {[info exists env(DEBUG_STUB)]} {source $env(DEBUG_STUB); " -1); Tcl_DStringAppend (&source_cmd, "debugger_init; debugger_eval {source {", -1); Tcl_DStringAppend (&source_cmd, gdbtk_file, -1); Tcl_DStringAppend (&source_cmd, "}}} else {source {", -1); @@ -2523,6 +699,10 @@ gdbtk_find_main"; #endif free (gdbtk_file); + + /* Now source in the filename provided by the --tclcommand option. + This is mostly used for the gdbtk testsuite... */ + if (gdbtk_source_filename != NULL) { char *s = "after idle source "; @@ -2531,1166 +711,15 @@ gdbtk_find_main"; free (gdbtk_source_filename); free (script); } - - discard_cleanups (old_chain); -} - -static int -gdb_target_has_execution_command (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - int result = 0; - - if (target_has_execution && inferior_pid != 0) - result = 1; - - Tcl_SetIntObj (Tcl_GetObjResult (interp), result); - return TCL_OK; -} - -static int -gdb_trace_status (clientData, interp, argc, argv) - ClientData clientData; - Tcl_Interp *interp; - int argc; - char *argv[]; -{ - int result = 0; - - if (trace_running_p) - result = 1; - - Tcl_SetIntObj (Tcl_GetObjResult (interp), result); - return TCL_OK; -} - -/* gdb_load_info - returns information about the file about to be downloaded */ - -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]; - Tcl_Obj *res[16]; - int i = 0; - - char *filename = Tcl_GetStringFromObj (objv[1], NULL); - - loadfile_bfd = bfd_openr (filename, gnutarget); - if (loadfile_bfd == NULL) - { - Tcl_SetObjResult (interp, Tcl_NewStringObj ("Open failed", -1)); - return TCL_ERROR; - } - old_cleanups = make_cleanup (bfd_close, loadfile_bfd); - - if (!bfd_check_format (loadfile_bfd, bfd_object)) - { - Tcl_SetObjResult (interp, Tcl_NewStringObj ("Bad Object File", -1)); - return TCL_ERROR; - } - - 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); - res[i++] = Tcl_NewListObj (2, ob); - } - } - } - Tcl_SetObjResult (interp, Tcl_NewListObj (i, res)); - do_cleanups (old_cleanups); - return TCL_OK; -} - - -int -gdbtk_load_hash (section, num) - char *section; - unsigned long num; -{ - char buf[128]; - sprintf (buf, "download_hash %s %ld", section, num); - Tcl_Eval (gdbtk_interp, buf); - return atoi (gdbtk_interp->result); -} - -/* 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); - -} - -/* gdb_get_vars_command - - * - * Implements the "gdb_get_locals" and "gdb_get_args" tcl commands. 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"). - */ -static int -gdb_get_vars_command (clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - Tcl_Obj *result; - struct symtabs_and_lines sals; - struct symbol *sym; - struct block *block; - char **canonical, *args; - int i, nsyms, arguments; - - if (objc != 2) - { - Tcl_AppendResult (interp, - "wrong # of args: should be \"", - Tcl_GetStringFromObj (objv[0], NULL), - " function:line|function|line|*addr\""); - 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_AppendResult (interp, - "error decoding line", NULL); - return TCL_ERROR; - } - - /* Initialize a list that will hold the results */ - result = Tcl_NewListObj (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, - Tcl_NewStringObj (SYMBOL_NAME (sym), -1)); - break; - case LOC_LOCAL: /* stack local */ - case LOC_STATIC: /* static */ - case LOC_REGISTER: /* register */ - case LOC_BASEREG: /* basereg local */ - if (!arguments) - Tcl_ListObjAppendElement (interp, result, - Tcl_NewStringObj (SYMBOL_NAME (sym), -1)); - break; - } - } - if (BLOCK_FUNCTION (block)) - break; - else - block = BLOCK_SUPERBLOCK (block); - } - - Tcl_SetObjResult (interp, result); - return TCL_OK; -} - -static int -gdb_get_line_command (clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - Tcl_Obj *result; - struct symtabs_and_lines sals; - char *args, **canonical; - - if (objc != 2) - { - Tcl_AppendResult (interp, "wrong # of args: should be \"", - Tcl_GetStringFromObj (objv[0], NULL), - " linespec\""); - return TCL_ERROR; - } - - args = Tcl_GetStringFromObj (objv[1], NULL); - sals = decode_line_1 (&args, 1, NULL, 0, &canonical); - if (sals.nelts == 1) - { - Tcl_SetObjResult (interp, Tcl_NewIntObj (sals.sals[0].line)); - return TCL_OK; - } - - Tcl_SetResult (interp, "N/A", TCL_STATIC); - 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_AppendResult (interp, "wrong # of args: should be \"", - Tcl_GetStringFromObj (objv[0], NULL), - " linespec\""); - return TCL_ERROR; - } - - Tcl_SetObjResult (interp, Tcl_NewIntObj (get_traceframe_number ())); - return TCL_OK; -} - - - -static int -gdb_get_file_command (clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - Tcl_Obj *result; - struct symtabs_and_lines sals; - char *args, **canonical; - - if (objc != 2) - { - Tcl_AppendResult (interp, "wrong # of args: should be \"", - Tcl_GetStringFromObj (objv[0], NULL), - " linespec\""); - return TCL_ERROR; - } - - args = Tcl_GetStringFromObj (objv[1], NULL); - sals = decode_line_1 (&args, 1, NULL, 0, &canonical); - if (sals.nelts == 1) - { - Tcl_SetResult (interp, sals.sals[0].symtab->filename, TCL_VOLATILE); - return TCL_OK; - } - - Tcl_SetResult (interp, "N/A", TCL_STATIC); - return TCL_OK; -} - -static int -gdb_get_function_command (clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - Tcl_Obj *result; - char *function; - struct symtabs_and_lines sals; - char *args, **canonical; - - if (objc != 2) - { - Tcl_AppendResult (interp, "wrong # of args: should be \"", - Tcl_GetStringFromObj (objv[0], NULL), - " linespec\""); - return TCL_ERROR; - } - - args = Tcl_GetStringFromObj (objv[1], NULL); - sals = decode_line_1 (&args, 1, NULL, 0, &canonical); - if (sals.nelts == 1) - { - resolve_sal_pc (&sals.sals[0]); - find_pc_partial_function (sals.sals[0].pc, &function, NULL, NULL); - if (function != NULL) - { - Tcl_SetResult (interp, function, TCL_VOLATILE); - return TCL_OK; - } - } - - Tcl_SetResult (interp, "N/A", TCL_STATIC); - 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 *list, *action_list; - char *filename, *funcname; - char tmp[19]; - - if (objc != 2) - error ("wrong # args"); - - Tcl_GetIntFromObj (NULL, objv[1], &tpnum); - - ALL_TRACEPOINTS (tp) - if (tp->number == tpnum) - break; - - if (tp == NULL) - error ("Tracepoint #%d does not exist", tpnum); - - list = Tcl_NewListObj (0, NULL); - sal = find_pc_line (tp->address, 0); - filename = symtab_to_filename (sal.symtab); - if (filename == NULL) - filename = "N/A"; - Tcl_ListObjAppendElement (interp, list, - Tcl_NewStringObj (filename, -1)); - find_pc_partial_function (tp->address, &funcname, NULL, NULL); - Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj (funcname, -1)); - Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (sal.line)); - sprintf (tmp, "0x%lx", tp->address); - Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj (tmp, -1)); - Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->enabled)); - Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->pass_count)); - Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->step_count)); - Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->thread)); - Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->hit_count)); - - /* Append a list of actions */ - action_list = Tcl_NewListObj (0, NULL); - for (al = tp->actions; al != NULL; al = al->next) - { - Tcl_ListObjAppendElement (interp, action_list, - Tcl_NewStringObj (al->action, -1)); - } - Tcl_ListObjAppendElement (interp, list, action_list); - - Tcl_SetObjResult (interp, list); - return TCL_OK; -} - - -/* TclDebug (const char *fmt, ...) works just like printf() but */ -/* sends the output to the GDB TK debug window. */ -/* Not for normal use; just a convenient tool for debugging */ -void -#ifdef ANSI_PROTOTYPES -TclDebug (const char *fmt, ...) -#else -TclDebug (va_alist) - va_dcl -#endif -{ - va_list args; - char buf[512], *v[2], *merge; - -#ifdef ANSI_PROTOTYPES - va_start (args, fmt); -#else - char *fmt; - va_start (args); - fmt = va_arg (args, char *); -#endif - - v[0] = "debug"; - v[1] = buf; - - vsprintf (buf, fmt, args); - va_end (args); - - merge = Tcl_Merge (2, v); - Tcl_Eval (gdbtk_interp, merge); - Tcl_Free (merge); -} - - -/* Find the full pathname to a file, searching the symbol tables */ - -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_SetObjResult (interp, Tcl_NewStringObj ("", 0)); - else - Tcl_SetObjResult (interp, Tcl_NewStringObj (filename, -1)); - - return TCL_OK; -} - -static void -gdbtk_create_tracepoint (tp) - struct tracepoint *tp; -{ - tracepoint_notify (tp, "create"); -} - -static void -gdbtk_delete_tracepoint (tp) - struct tracepoint *tp; -{ - tracepoint_notify (tp, "delete"); -} - -static void -gdbtk_modify_tracepoint (tp) - struct tracepoint *tp; -{ - tracepoint_notify (tp, "modify"); -} - -static void -tracepoint_notify(tp, action) - struct tracepoint *tp; - const char *action; -{ - char buf[256]; - int v; - struct symtab_and_line sal; - char *filename; - - /* We ensure that ACTION contains no special Tcl characters, so we - can do this. */ - sal = find_pc_line (tp->address, 0); - - filename = symtab_to_filename (sal.symtab); - if (filename == NULL) - filename = "N/A"; - sprintf (buf, "gdbtk_tcl_tracepoint %s %d 0x%lx %d {%s}", action, tp->number, - (long)tp->address, sal.line, filename, tp->pass_count); - - v = Tcl_Eval (gdbtk_interp, buf); - - if (v != TCL_OK) - { - gdbtk_fputs (gdbtk_interp->result, gdb_stdout); - gdbtk_fputs ("\n", gdb_stdout); - } -} - -/* 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_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_AppendResult (interp, "wrong # args: should be: \"", - Tcl_GetStringFromObj (objv[0], NULL), - " number actions\""); - return TCL_ERROR; - } - - args = number = Tcl_GetStringFromObj (objv[1], NULL); - tp = get_tracepoint_by_number (&args); - if (tp == NULL) - { - Tcl_AppendResult (interp, "Tracepoint \"", number, "\" does not exist"); - 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; -} - -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_AppendResult (interp, "wrong # of args: should be \"", - Tcl_GetStringFromObj (objv[0], NULL), - " function:line|function|line|*addr\""); - return TCL_ERROR; - } - - args = Tcl_GetStringFromObj (objv[1], NULL); - - Tcl_SetObjResult (interp, Tcl_NewIntObj (tracepoint_exists (args))); - return TCL_OK; -} - -/* Return the prompt to the interpreter */ -static int -gdb_prompt_command (clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - Tcl_SetResult (interp, get_prompt (), TCL_VOLATILE); - return TCL_OK; -} - -/* 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[]; -{ - Tcl_Obj *list; - struct tracepoint *tp; - - list = Tcl_NewListObj (0, NULL); - - ALL_TRACEPOINTS (tp) - Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->number)); - - Tcl_SetObjResult (interp, list); - return TCL_OK; -} - - -/* This hook is called whenever we are ready to load a symbol file so that - the UI can notify the user... */ -void -gdbtk_pre_add_symbol (name) - char *name; -{ - char *merge, *v[2]; - - v[0] = "gdbtk_tcl_pre_add_symbol"; - v[1] = name; - merge = Tcl_Merge (2, v); - Tcl_Eval (gdbtk_interp, merge); - Tcl_Free (merge); -} - -/* This hook is called whenever we finish loading a symbol file. */ -void -gdbtk_post_add_symbol () -{ - Tcl_Eval (gdbtk_interp, "gdbtk_tcl_post_add_symbol"); -} - - - -static void -gdbtk_print_frame_info (s, line, stopline, noerror) - struct symtab *s; - int line; - int stopline; - int noerror; -{ - current_source_symtab = s; - current_source_line = line; -} - - -/* 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; -} - -static int -perror_with_name_wrapper (args) - char * args; -{ - perror_with_name (args); - return 1; -} - -/* gdb_loadfile loads a c source file into a text widget. */ - -/* 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, *line, *buf, msg[128]; - int linenumbers, ln, anum, lnum, ltable_size; - Tcl_Obj *a[2], *b[2], *cmd; - FILE *fp; - char *ltable; - struct symtab *symtab; - struct linetable_entry *le; - long mtime = 0; - struct stat st; - - - if (objc != 4) - { - Tcl_WrongNumArgs(interp, 1, objv, "widget filename linenumbers"); - return TCL_ERROR; - } - - widget = Tcl_GetStringFromObj (objv[1], NULL); - file = Tcl_GetStringFromObj (objv[2], NULL); - Tcl_GetBooleanFromObj (interp, objv[3], &linenumbers); - - if ((fp = fopen ( file, "r" )) == NULL) - return TCL_ERROR; - - symtab = full_lookup_symtab (file); - if (!symtab) - { - sprintf(msg, "File not found"); - Tcl_SetStringObj ( Tcl_GetObjResult (interp), msg, -1); - fclose (fp); - 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) - { - sprintf(msg, "Out of memory."); - Tcl_SetStringObj ( Tcl_GetObjResult (interp), msg, -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) - { - sprintf(msg, "Out of memory."); - Tcl_SetStringObj ( Tcl_GetObjResult (interp), msg, -1); - free (ltable); - fclose (fp); - return TCL_ERROR; - } - ltable = new_ltable; - } - ltable[lnum] |= 1 << (le->line % 8); - } - } - - /* create an object with enough space, then grab its */ - /* buffer and sprintf directly into it. */ - a[0] = Tcl_NewStringObj (ltable, 1024); - a[1] = Tcl_NewListObj(0,NULL); - buf = a[0]->bytes; - b[0] = Tcl_NewStringObj (ltable,1024); - b[1] = Tcl_NewStringObj ("source_tag", -1); - Tcl_IncrRefCount (b[0]); - Tcl_IncrRefCount (b[1]); - line = b[0]->bytes + 1; - strcpy(b[0]->bytes,"\t"); - - ln = 1; - while (fgets (line, 980, fp)) - { - if (linenumbers) - { - if (ltable[ln >> 3] & (1 << (ln % 8))) - { - sprintf (buf,"%s insert end {-\t%d} break_tag", widget, ln); - a[0]->length = strlen (buf); - } - else - { - sprintf (buf,"%s insert end { \t%d} \"\"", widget, ln); - a[0]->length = strlen (buf); - } - } - else - { - if (ltable[ln >> 3] & (1 << (ln % 8))) - { - sprintf (buf,"%s insert end {-\t} break_tag", widget); - a[0]->length = strlen (buf); - } - else - { - sprintf (buf,"%s insert end { \t} \"\"", widget); - a[0]->length = strlen (buf); - } - } - b[0]->length = strlen(b[0]->bytes); - Tcl_SetListObj(a[1],2,b); - cmd = Tcl_ConcatObj(2,a); - Tcl_EvalObj (interp, cmd); - Tcl_DecrRefCount (cmd); - ln++; - } - Tcl_DecrRefCount (b[0]); - Tcl_DecrRefCount (b[0]); - Tcl_DecrRefCount (b[1]); - Tcl_DecrRefCount (b[1]); - free (ltable); - fclose (fp); - return TCL_OK; -} - -/* 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; - -/* 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 - }; -*/ -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; - struct breakpoint *b; - char buf[64]; - Tcl_Obj *a[5], *cmd; - - if (objc != 4) - { - Tcl_WrongNumArgs(interp, 1, objv, "filename line type"); - 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) - return TCL_ERROR; - - if (Tcl_GetIntFromObj( interp, objv[3], &flags) == TCL_ERROR) - 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; - - /* 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 */ - sprintf (buf, "0x%x", sal.pc); - a[0] = Tcl_NewStringObj ("gdbtk_tcl_breakpoint create", -1); - a[1] = Tcl_NewIntObj (b->number); - a[2] = Tcl_NewStringObj (buf, -1); - a[3] = objv[2]; - a[4] = Tcl_NewListObj (1,&objv[1]); - cmd = Tcl_ConcatObj(5,a); - ret = Tcl_EvalObj (interp, cmd); - Tcl_DecrRefCount (cmd); - return ret; + discard_cleanups (old_chain); } -static int -gdb_search (clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp *interp; - int objc; - Tcl_Obj *CONST objv[]; -{ - struct symbol_search *ss; - struct symbol_search *p; - struct cleanup *old_chain; - Tcl_Obj *list, *result, *CONST *switch_objv; - int index, switch_objc, i; - namespace_enum space; - char *regexp, *val; - int static_only, nfiles; - Tcl_Obj **file_list; - char **files; - static char *search_options[] = { "functions", "variables", "types", (char *) NULL }; - static char *switches[] = { "-files", "-static" }; - 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 ...?"); - return TCL_ERROR; - } - - if (Tcl_GetIndexFromObj (interp, objv[1], search_options, "option", 0, - &index) != TCL_OK) - 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) - return TCL_ERROR; - - switch ((enum switches_opts) index) - { - case SWITCH_FILES: - if (switch_objc < 2) - { - Tcl_WrongNumArgs (interp, 2, objv, "[-files fileList -static 1|0]"); - return TCL_ERROR; - } - Tcl_ListObjGetElements (interp, switch_objv[1], &nfiles, &file_list); - files = (char **) xmalloc (nfiles); - old_chain = make_cleanup (free, files); - - 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]"); - return TCL_ERROR; - } - Tcl_GetIntFromObj (interp, switch_objv[1], &static_only); - switch_objc--; - switch_objv++; - } - - switch_objc--; - switch_objv++; - } - - search_symbols (regexp, space, nfiles, files, &ss); - if (files != NULL && ss != NULL) - do_cleanups (old_chain); - old_chain = make_cleanup (free_search_symbols, ss); - - list = Tcl_NewListObj (0, NULL); - for (p = ss; p != NULL; p = p->next) - { - Tcl_Obj *elem; - - if (static_only && p->block != STATIC_BLOCK) - continue; - - 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, list, elem); - } +/* gdbtk_test is used in main.c to validate the -tclcommand option to + gdb, which sources in a file of tcl code after idle during the + startup procedure. */ - Tcl_SetObjResult (interp, list); - do_cleanups (old_chain); - return TCL_OK; -} - int gdbtk_test (filename) char *filename; @@ -3701,7 +730,7 @@ gdbtk_test (filename) gdbtk_source_filename = xstrdup (filename); return 1; } - + /* Come here during initialize_all_files () */ void @@ -3744,3 +773,31 @@ _initialize_gdbtk () } #endif } + +static void +tk_command (cmd, from_tty) + char *cmd; + int from_tty; +{ + int retval; + char *result; + struct cleanup *old_chain; + + /* Catch case of no argument, since this will make the tcl interpreter dump core. */ + if (cmd == NULL) + error_no_arg ("tcl command to interpret"); + + retval = Tcl_Eval (gdbtk_interp, cmd); + + result = strdup (gdbtk_interp->result); + + old_chain = make_cleanup (free, result); + + if (retval != TCL_OK) + error (result); + + printf_unfiltered ("%s\n", result); + + do_cleanups (old_chain); +} + diff --git a/gdb/gdbtk.h b/gdb/gdbtk.h new file mode 100644 index 0000000..0b5e59f --- /dev/null +++ b/gdb/gdbtk.h @@ -0,0 +1,145 @@ +/* Tcl/Tk interface routines header file. + 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. It contains the public data that is shared between +the gdbtk startup code and the gdbtk commands. + +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. */ + +#ifdef WINNT +#define GDBTK_PATH_SEP ";" +#else +#define GDBTK_PATH_SEP ":" +#endif + +/* Some versions (1.3.79, 1.3.81) of Linux don't support SIOCSPGRP the way + gdbtk wants to use it... */ +#ifdef __linux__ +#undef SIOCSPGRP +#endif + +/* + * These are the version numbers for GDBTK. There is a package require + * statement in main.tcl that checks the version. If you make an incompatible + * change to the gdb commands, or add any new commands, be sure to bump the + * version number both here and in main.tcl. This will save us the trouble of + * having a version of gdb find the wrong versions of the Tcl libraries. + */ + +#define GDBTK_MAJOR_VERSION "1" +#define GDBTK_MINOR_VERSION "0" +#define GDBTK_VERSION "1.0" + +/* + * These are variables that are needed in gdbtk commands. + */ + +/* This variable determines where memory used for disassembly is read from. + If > 0, then disassembly comes from the exec file rather than the + target (which might be at the other end of a slow serial link). If + == 0 then disassembly comes from target. If < 0 disassembly is + automatically switched to the target if it's an inferior process, + otherwise the exec file is used. It is defined in gdbtk.c */ + + +extern int disassemble_from_exec; + +/* This variable is true when the inferior is running. Although it's + possible to disable most input from widgets and thus prevent + attempts to do anything while the inferior is running, any commands + that get through - even a simple memory read - are Very Bad, and + may cause GDB to crash or behave strangely. So, this variable + provides an extra layer of defense. It is defined in gdbtk.c */ + +extern int running_now; + +/* These two control how the GUI behaves when tracing or loading + They are defined in gdbtk_cmds.c */ + +extern int No_Update; +extern int load_in_progress; + +/* This is the main gdbtk interpreter. It is defined and initialized + in gdbtk.c */ + +extern Tcl_Interp *gdbtk_interp; + +/* + * This structure controls how the gdb output is fed into call_wrapper invoked + * commands. See the explanation of gdbtk_fputs in gdbtk_hooks.c for more details. + */ + +typedef struct gdbtk_result { + Tcl_Obj *obj_ptr; /* This will eventually be copied over to the + Tcl result */ + int flags; /* Flag vector to control how the result is + used. */ +} gdbtk_result; + +/* These defines give the allowed values for the gdbtk_result.flags field. */ + +#define GDBTK_TO_RESULT 1 /* This controls whether output from + gdbtk_fputs goes to the command result, or + to gdbtk_tcl_fputs. */ +#define GDBTK_MAKES_LIST 2 /* whether gdbtk_fputs adds the + element it is outputting as a string, or + as a separate list element. */ +#define GDBTK_IN_TCL_RESULT 4 /* Indicates that the result is already in the + Tcl result. You can use this to preserve + error messages from functions like + Tcl_GetIntFromObj. You can also store the + output of a call wrapped command directly in + the Tcl result if you want, but beware, it will + not then be preserved across recursive + call_wrapper invocations. */ +#define GDBTK_ERROR_STARTED 8 /* This one is just used in gdbtk_fputs. If we + see some output on stderr, we need to clear + the result we have been accumulating, or the + error and the previous successful output + will get mixed, which would be confusing. */ + + +/* This is a pointer to the gdbtk_result struct that + we are currently filling. We use the C stack to make a stack of these + structures for nested calls to gdbtk commands that are invoked through + the call_wrapper mechanism. See that function for more details. */ + +extern gdbtk_result *result_ptr; + +/* + * These functions are used in all the modules of Gdbtk. + * + */ + +extern int Gdbtk_Init(Tcl_Interp *interp); +extern void gdbtk_stop_timer PARAMS ((void)); +extern void gdbtk_start_timer PARAMS ((void)); +extern void gdbtk_ignorable_warning PARAMS ((const char *)); +extern void gdbtk_interactive PARAMS ((void)); +extern void x_event PARAMS ((int)); +extern int gdbtk_two_elem_cmd PARAMS ((char *, char *)); + +#ifdef _WIN32 +extern void close_bfds (); +#endif /* _WIN32 */ + +extern void +#ifdef ANSI_PROTOTYPES +TclDebug (const char *fmt, ...); +#else +TclDebug (va_alist); +#endif diff --git a/gdb/gdbtk_cmds.c b/gdb/gdbtk_cmds.c new file mode 100644 index 0000000..221e3e6 --- /dev/null +++ b/gdb/gdbtk_cmds.c @@ -0,0 +1,3075 @@ +/* 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 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; + + +/* + * Declarations for routines used only in this file. + */ + +int Gdbtk_Init (Tcl_Interp *interp); +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_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 void gdbtk_create_breakpoint PARAMS ((struct breakpoint *)); +static int gdbtk_dis_asm_read_memory PARAMS ((bfd_vma, bfd_byte *, int, disassemble_info *)); +static void gdbtk_create_tracepoint PARAMS ((struct tracepoint *)); +static void gdbtk_delete_breakpoint PARAMS ((struct breakpoint *)); +static void gdbtk_delete_tracepoint PARAMS ((struct tracepoint *)); +static void gdbtk_modify_breakpoint PARAMS ((struct breakpoint *)); +static void gdbtk_modify_tracepoint PARAMS ((struct tracepoint *)); +static void gdbtk_print_frame_info PARAMS ((struct symtab *, int, int, int)); +static void gdbtk_readline_end PARAMS ((void)); +static int get_pc_register 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 void pc_changed PARAMS ((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); + +/* 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_get_trace_frame_num", + call_wrapper, gdb_get_trace_frame_num, NULL); + + 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; + int length; + + 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_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; + 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 (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_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[]; +{ + + 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 = 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) + || (strncmp ("while ", Tcl_GetStringFromObj (objv[1], NULL), 6) == 0)) + { + result_ptr->flags &= ~GDBTK_TO_RESULT; + load_in_progress = 1; + gdbtk_start_timer (); + } + + execute_command (Tcl_GetStringFromObj (objv[1], NULL), 1); + + if (load_in_progress) + { + gdbtk_stop_timer (); + 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]; + int i = 0; + + 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 (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_STATIC: /* static */ + case LOC_REGISTER: /* register */ + 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 */ + 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[]; +{ + Tcl_Obj *result; + 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[]; +{ + Tcl_Obj *result; + 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. + * + * Arguments: + * ?pathname? - If provided, only files which match pathname + * (up to strlen(pathname)) are included. + * 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, **files; + int files_size; + int i, numfiles = 0, len = 0; + Tcl_Obj *mylist; + + 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 (len == 0) + { + if (psymtab->filename) + files[numfiles++] = basename(psymtab->filename); + } + else if (!strcmp(psymtab->filename,basename(psymtab->filename)) + || !strncmp(pathname,psymtab->filename,len)) + if (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 (len == 0) + { + if (symtab->filename) + files[numfiles++] = basename(symtab->filename); + } + else if (!strcmp(symtab->filename,basename(symtab->filename)) + || !strncmp(pathname,symtab->filename,len)) + if (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; + struct symbol_search *p; + struct cleanup *old_chain; + Tcl_Obj *list, *result, *CONST *switch_objv; + int index, switch_objc, i; + namespace_enum space; + char *regexp, *val; + int static_only, nfiles; + Tcl_Obj **file_list; + char **files; + static char *search_options[] = { "functions", "variables", "types", (char *) NULL }; + static char *switches[] = { "-files", "-static" }; + 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 ...?"); + return TCL_ERROR; + } + + if (Tcl_GetIndexFromObj (interp, objv[1], search_options, "option", 0, + &index) != TCL_OK) + 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: + if (switch_objc < 2) + { + Tcl_WrongNumArgs (interp, 2, objv, "[-files fileList -static 1|0]"); + result_ptr->flags |= GDBTK_IN_TCL_RESULT; + return TCL_ERROR; + } + Tcl_ListObjGetElements (interp, switch_objv[1], &nfiles, &file_list); + files = (char **) xmalloc (nfiles); + old_chain = make_cleanup (free, files); + + 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 (files != NULL && ss != NULL) + do_cleanups (old_chain); + old_chain = make_cleanup (free_search_symbols, ss); + + Tcl_SetListObj(result_ptr->obj_ptr, 0, NULL); + + for (p = ss; p != NULL; p = p->next) + { + Tcl_Obj *elem; + + if (static_only && p->block != STATIC_BLOCK) + continue; + + 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); + } + + 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; + char buf[128]; + 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) + { + funcVals[0] = Tcl_NewStringObj(name, -1); + funcVals[1] = mangled; + } + 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 + reg_names array because NUM_REGS may be allocated for the union of the + register sets within a family of related processors. In this case, the + trailing entries of reg_names 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 + && reg_names[regnum] != NULL + && *reg_names[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 + && reg_names[regnum] != NULL + && *reg_names[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 (reg_names[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; + + if (format == 'N') + format = 0; + + if (read_relative_register_raw_bytes (regnum, raw_buffer)) + { + 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, + 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; + 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) + { + Tcl_SetStringObj (result_ptr->obj_ptr, "Tracepoint #%d does not exist", -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); + 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 = tm_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) + 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, *ptr, 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, *buf, msg[128]; + int linenumbers, ln, anum, 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); + + if ((fp = fopen ( file, "r" )) == NULL) + { + Tcl_SetStringObj ( result_ptr->obj_ptr, "Can't open file for reading", -1); + return TCL_ERROR; + } + + symtab = full_lookup_symtab (file); + if (!symtab) + { + Tcl_SetStringObj ( result_ptr->obj_ptr, "File not found in symtab", -1); + fclose (fp); + 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_tag", 11); + } + 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 {-\t} break_tag", -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)) + { + 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 + * 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; + struct breakpoint *b; + char buf[64]; + Tcl_DString cmd; + + if (objc != 4) + { + Tcl_WrongNumArgs(interp, 1, objv, "filename line type"); + 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; + } + + 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; + + /* 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%x", sal.pc); + Tcl_DStringAppendElement (&cmd, buf); + Tcl_DStringAppendElement (&cmd, Tcl_GetStringFromObj (objv[2], NULL)); + Tcl_DStringAppendElement (&cmd, Tcl_GetStringFromObj (objv[1], NULL)); + + ret = Tcl_Eval (interp, Tcl_DStringValue (&cmd)); + Tcl_DStringFree (&cmd); + return ret; +} + +/* 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; + static 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" }; + static char *bpdisp[] = {"delete", "delstop", "disable", "donttouch"}; + 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) + { + Tcl_SetStringObj (result_ptr->obj_ptr, "Breakpoint #%d does not exist", -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; +} + + +/* + * 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 WINNT + { + 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; +} diff --git a/gdb/gdbtk_hooks.c b/gdb/gdbtk_hooks.c new file mode 100644 index 0000000..f87efe1 --- /dev/null +++ b/gdb/gdbtk_hooks.c @@ -0,0 +1,689 @@ +/* Startup code 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> + +int in_fputs = 0; + +int (*ui_load_progress_hook) PARAMS ((char *, unsigned long)); +void (*pre_add_symbol_hook) PARAMS ((char *)); +void (*post_add_symbol_hook) PARAMS ((void)); + +#ifdef __CYGWIN32__ +extern void (*ui_loop_hook) PARAMS ((int)); +#endif +static void gdbtk_create_tracepoint PARAMS ((struct tracepoint *)); +static void gdbtk_delete_tracepoint PARAMS ((struct tracepoint *)); +static void gdbtk_modify_tracepoint PARAMS ((struct tracepoint *)); +static void gdbtk_create_breakpoint PARAMS ((struct breakpoint *)); +static void gdbtk_delete_breakpoint PARAMS ((struct breakpoint *)); +static void gdbtk_modify_breakpoint PARAMS ((struct breakpoint *)); +static void tk_command_loop PARAMS ((void)); +static void gdbtk_call_command PARAMS ((struct cmd_list_element *, char *, int)); +static int gdbtk_wait PARAMS ((int, struct target_waitstatus *)); + void x_event PARAMS ((int)); +static int gdbtk_query PARAMS ((const char *, va_list)); +static void gdbtk_warning PARAMS ((const char *, va_list)); +void gdbtk_ignorable_warning PARAMS ((const char *)); +static char* gdbtk_readline PARAMS ((char *)); +static void +#ifdef ANSI_PROTOTYPES +gdbtk_readline_begin (char *format, ...); +#else +gdbtk_readline_begin (); +#endif +static void gdbtk_readline_end PARAMS ((void)); +static void gdbtk_flush PARAMS ((FILE *)); +static void gdbtk_pre_add_symbol PARAMS ((char *)); +static void gdbtk_print_frame_info PARAMS ((struct symtab *, int, int, int)); +static void gdbtk_post_add_symbol PARAMS ((void)); +static void pc_changed PARAMS ((void)); +static void tracepoint_notify PARAMS ((struct tracepoint *, const char *)); + +/* + * gdbtk_fputs can't be static, because we need to call it in gdbtk.c. + * See note there for details. + */ + +void gdbtk_fputs PARAMS ((const char *, FILE *)); +int gdbtk_load_hash PARAMS ((char *, unsigned long)); +static void breakpoint_notify PARAMS ((struct breakpoint *, const char *)); + +/* + * gdbtk_add_hooks - add all the hooks to gdb. This will get called by the + * startup code to fill in the hooks needed by core gdb. + */ + +void +gdbtk_add_hooks(void) +{ + command_loop_hook = tk_command_loop; + call_command_hook = gdbtk_call_command; + readline_begin_hook = gdbtk_readline_begin; + readline_hook = gdbtk_readline; + readline_end_hook = gdbtk_readline_end; + + print_frame_info_listing_hook = gdbtk_print_frame_info; + query_hook = gdbtk_query; + warning_hook = gdbtk_warning; + flush_hook = gdbtk_flush; + + create_breakpoint_hook = gdbtk_create_breakpoint; + delete_breakpoint_hook = gdbtk_delete_breakpoint; + modify_breakpoint_hook = gdbtk_modify_breakpoint; + + interactive_hook = gdbtk_interactive; + target_wait_hook = gdbtk_wait; + ui_load_progress_hook = gdbtk_load_hash; +#ifdef __CYGWIN32__ + ui_loop_hook = x_event; +#endif + pre_add_symbol_hook = gdbtk_pre_add_symbol; + post_add_symbol_hook = gdbtk_post_add_symbol; + + create_tracepoint_hook = gdbtk_create_tracepoint; + delete_tracepoint_hook = gdbtk_delete_tracepoint; + modify_tracepoint_hook = gdbtk_modify_tracepoint; + pc_changed_hook = pc_changed; + +} + +/* These control where to put the gdb output which is created by + {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the + lowest level of these routines and capture all output from the rest of GDB. + + The reason to use the result_ptr rather than the gdbtk_interp's result + directly is so that a call_wrapper invoked function can preserve its result + across calls into Tcl which might be made in the course of the function's + execution. + + * result_ptr->obj_ptr is where to accumulate the result. + * GDBTK_TO_RESULT flag means the output goes to the gdbtk_tcl_fputs proc + instead of to the result_ptr. + * GDBTK_MAKES_LIST flag means add to the result as a list element. + + */ + +gdbtk_result *result_ptr = NULL; + + +/* This allows you to Tcl_Eval a tcl command which takes + a command word, and then a single argument. */ + +int gdbtk_two_elem_cmd (cmd_name, argv1) + char *cmd_name; + char * argv1; +{ + char *command; + int result, flags_ptr, arg_len, cmd_len; + + arg_len = Tcl_ScanElement (argv1, &flags_ptr); + cmd_len = strlen (cmd_name); + command = malloc(arg_len + cmd_len + 2); + strcpy (command, cmd_name); + strcat (command, " "); + + Tcl_ConvertElement (argv1, command + cmd_len + 1, flags_ptr); + + result = Tcl_Eval (gdbtk_interp, command); + free (command); + return result; + +} + +static void +gdbtk_flush (stream) + FILE *stream; +{ +#if 0 + /* Force immediate screen update */ + + Tcl_VarEval (gdbtk_interp, "gdbtk_tcl_flush", NULL); +#endif +} + +/* This handles all the output from gdb. All the gdb printf_xxx functions + * eventually end up here. The output is either passed to the result_ptr + * where it will go to the result of some gdbtk command, or passed to the + * Tcl proc gdbtk_tcl_fputs (where it is usually just dumped to the console + * window. + * + * The cases are: + * + * 1) result_ptr == NULL - This happens when some output comes from gdb which + * is not generated by a command in gdbtk_cmds, usually startup stuff. + * In this case we just route the data to gdbtk_tcl_fputs. + * 2) The GDBTK_TO_RESULT flag is set - The result is supposed to go to Tcl. + * We place the data into the result_ptr, either as a string, + * or a list, depending whether the GDBTK_MAKES_LIST bit is set. + * 3) The GDBTK_TO_RESULT flag is unset - We route the data to gdbtk_tcl_fputs + * UNLESS it was coming to stderr. Then we place it in the result_ptr + * anyway, so it can be dealt with. + * + */ + +void +gdbtk_fputs (ptr, stream) + const char *ptr; + FILE *stream; +{ + in_fputs = 1; + + if (result_ptr != NULL) + { + if (result_ptr->flags & GDBTK_TO_RESULT) + { + if (result_ptr->flags & GDBTK_MAKES_LIST) + Tcl_ListObjAppendElement(NULL, result_ptr->obj_ptr, + Tcl_NewStringObj((char *) ptr, -1)); + else + Tcl_AppendToObj (result_ptr->obj_ptr, (char *) ptr, -1); + } + else if (stream == gdb_stderr) + { + if (result_ptr->flags & GDBTK_ERROR_STARTED) + Tcl_AppendToObj (result_ptr->obj_ptr, (char *) ptr, -1); + else + { + Tcl_SetStringObj (result_ptr->obj_ptr, (char *) ptr, -1); + result_ptr->flags |= GDBTK_ERROR_STARTED; + } + } + else + { + gdbtk_two_elem_cmd ("gdbtk_tcl_fputs", (char *) ptr); + if (result_ptr->flags & GDBTK_MAKES_LIST) + gdbtk_two_elem_cmd ("gdbtk_tcl_fputs", " "); + } + } + else + { + gdbtk_two_elem_cmd ("gdbtk_tcl_fputs", (char *) ptr); + } + + in_fputs = 0; +} + +/* + * This routes all warnings to the Tcl function "gdbtk_tcl_warning". + */ + +static void +gdbtk_warning (warning, args) + const char *warning; + va_list args; +{ + char buf[200]; + + vsprintf (buf, warning, args); + gdbtk_two_elem_cmd ("gdbtk_tcl_warning", buf); + +} + +/* + * This routes all ignorable warnings to the Tcl function + * "gdbtk_tcl_ignorable_warning". + */ + +void +gdbtk_ignorable_warning (warning) + const char *warning; +{ + char buf[200], *merge[2]; + char *command; + + sprintf (buf, warning); + gdbtk_two_elem_cmd ("gdbtk_tcl_ignorable_warning", buf); + +} + + + +static void +pc_changed() +{ + Tcl_Eval (gdbtk_interp, "gdbtk_pc_changed"); +} + + +/* This function is called instead of gdb's internal command loop. This is the + last chance to do anything before entering the main Tk event loop. + At the end of the command, we enter the main loop. */ + +static void +tk_command_loop () +{ + extern GDB_FILE *instream; + + /* We no longer want to use stdin as the command input stream */ + instream = NULL; + + if (Tcl_Eval (gdbtk_interp, "gdbtk_tcl_preloop") != TCL_OK) + { + char *msg; + + /* Force errorInfo to be set up propertly. */ + Tcl_AddErrorInfo (gdbtk_interp, ""); + + msg = Tcl_GetVar (gdbtk_interp, "errorInfo", TCL_GLOBAL_ONLY); +#ifdef _WIN32 + MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL); +#else + fputs_unfiltered (msg, gdb_stderr); +#endif + } + +#ifdef _WIN32 + close_bfds (); +#endif + + Tk_MainLoop (); +} + +/* Come here when there is activity on the X file descriptor. */ + +void +x_event (signo) + int signo; +{ + static int in_x_event = 0; + static Tcl_Obj *varname = NULL; + if (in_x_event || in_fputs) + return; + + in_x_event = 1; + +#ifdef __CYGWIN32__ + if (signo == -2) + gdbtk_stop_timer (); +#endif + + /* Process pending events */ + while (Tcl_DoOneEvent (TCL_DONT_WAIT|TCL_ALL_EVENTS) != 0) + ; + + if (load_in_progress) + { + int val; + if (varname == NULL) + { + Tcl_Obj *varnamestrobj = Tcl_NewStringObj("download_cancel_ok",-1); + varname = Tcl_ObjGetVar2(gdbtk_interp,varnamestrobj,NULL,TCL_GLOBAL_ONLY); + } + if ((Tcl_GetIntFromObj(gdbtk_interp,varname,&val) == TCL_OK) && val) + { + quit_flag = 1; +#ifdef REQUEST_QUIT + REQUEST_QUIT; +#else + if (immediate_quit) + quit (); +#endif + } + } + in_x_event = 0; +} + +/* VARARGS */ +static void +#ifdef ANSI_PROTOTYPES +gdbtk_readline_begin (char *format, ...) +#else +gdbtk_readline_begin (va_alist) + va_dcl +#endif +{ + va_list args; + char buf[200], *merge[2]; + char *command; + +#ifdef ANSI_PROTOTYPES + va_start (args, format); +#else + char *format; + va_start (args); + format = va_arg (args, char *); +#endif + + vsprintf (buf, format, args); + gdbtk_two_elem_cmd ("gdbtk_tcl_readline_begin", buf); + +} + +static char * +gdbtk_readline (prompt) + char *prompt; +{ + int result; + +#ifdef _WIN32 + close_bfds (); +#endif + + result = gdbtk_two_elem_cmd ("gdbtk_tcl_readline", prompt); + + if (result == TCL_OK) + { + return (strdup (gdbtk_interp -> result)); + } + else + { + gdbtk_fputs (gdbtk_interp -> result, gdb_stdout); + gdbtk_fputs ("\n", gdb_stdout); + return (NULL); + } +} + +static void +gdbtk_readline_end () +{ + Tcl_Eval (gdbtk_interp, "gdbtk_tcl_readline_end"); +} + +static void +gdbtk_call_command (cmdblk, arg, from_tty) + struct cmd_list_element *cmdblk; + char *arg; + int from_tty; +{ + running_now = 0; + if (cmdblk->class == class_run || cmdblk->class == class_trace) + { + +/* HACK! HACK! This is to get the gui to update the tstart/tstop + button only incase of tstart/tstop commands issued from the console + We don't want to update the src window, so we need to have specific + procedures to do tstart and tstop + Unfortunately this will not display errors from tstart or tstop in the + console window itself, but as dialogs.*/ + + if (!strcmp(cmdblk->name, "tstart") && !No_Update) + { + Tcl_Eval (gdbtk_interp, "gdbtk_tcl_tstart"); + (*cmdblk->function.cfunc)(arg, from_tty); + } + else if (!strcmp(cmdblk->name, "tstop") && !No_Update) + { + Tcl_Eval (gdbtk_interp, "gdbtk_tcl_tstop"); + (*cmdblk->function.cfunc)(arg, from_tty); + } +/* end of hack */ + else + { + running_now = 1; + if (!No_Update) + Tcl_Eval (gdbtk_interp, "gdbtk_tcl_busy"); + (*cmdblk->function.cfunc)(arg, from_tty); + running_now = 0; + if (!No_Update) + Tcl_Eval (gdbtk_interp, "gdbtk_tcl_idle"); + } + } + else + (*cmdblk->function.cfunc)(arg, from_tty); +} + +/* The next three functions use breakpoint_notify to allow the GUI + * to handle creating, deleting and modifying breakpoints. These three + * functions are put into the appropriate gdb hooks in gdbtk_init. + */ + +static void +gdbtk_create_breakpoint(b) + struct breakpoint *b; +{ + breakpoint_notify (b, "create"); +} + +static void +gdbtk_delete_breakpoint(b) + struct breakpoint *b; +{ + breakpoint_notify (b, "delete"); +} + +static void +gdbtk_modify_breakpoint(b) + struct breakpoint *b; +{ + breakpoint_notify (b, "modify"); +} + +/* This is the generic function for handling changes in + * a breakpoint. It routes the information to the Tcl + * command "gdbtk_tcl_breakpoint" in the form: + * gdbtk_tcl_breakpoint action b_number b_address b_line b_file + * On error, the error string is written to gdb_stdout. + */ + +static void +breakpoint_notify(b, action) + struct breakpoint *b; + const char *action; +{ + char buf[256]; + int v; + struct symtab_and_line sal; + char *filename; + + if (b->type != bp_breakpoint) + return; + + /* We ensure that ACTION contains no special Tcl characters, so we + can do this. */ + sal = find_pc_line (b->address, 0); + filename = symtab_to_filename (sal.symtab); + if (filename == NULL) + filename = ""; + + sprintf (buf, "gdbtk_tcl_breakpoint %s %d 0x%lx %d {%s}", action, b->number, + (long)b->address, b->line_number, filename); + + v = Tcl_Eval (gdbtk_interp, buf); + + if (v != TCL_OK) + { + gdbtk_fputs (Tcl_GetStringResult (gdbtk_interp), gdb_stdout); + gdbtk_fputs ("\n", gdb_stdout); + } +} + +int +gdbtk_load_hash (section, num) + char *section; + unsigned long num; +{ + char buf[128]; + sprintf (buf, "download_hash %s %ld", section, num); + Tcl_Eval (gdbtk_interp, buf); + return atoi (gdbtk_interp->result); +} + + +/* This hook is called whenever we are ready to load a symbol file so that + the UI can notify the user... */ +static void +gdbtk_pre_add_symbol (name) + char *name; +{ + + gdbtk_two_elem_cmd("gdbtk_tcl_pre_add_symbol", name); + +} + +/* This hook is called whenever we finish loading a symbol file. */ +static void +gdbtk_post_add_symbol () +{ + Tcl_Eval (gdbtk_interp, "gdbtk_tcl_post_add_symbol"); +} + +/* This hook function is called whenever we want to wait for the + target. */ + +static int +gdbtk_wait (pid, ourstatus) + int pid; + struct target_waitstatus *ourstatus; +{ + gdbtk_start_timer (); + pid = target_wait (pid, ourstatus); + gdbtk_stop_timer (); + return pid; +} + +/* + * This handles all queries from gdb. + * The first argument is a printf style format statement, the rest are its + * arguments. The resultant formatted string is passed to the Tcl function + * "gdbtk_tcl_query". + * It returns the users response to the query, as well as putting the value + * in the result field of the Tcl interpreter. + */ + +static int +gdbtk_query (query, args) + const char *query; + va_list args; +{ + char buf[200]; + long val; + + vsprintf (buf, query, args); + gdbtk_two_elem_cmd ("gdbtk_tcl_query", buf); + + val = atol (gdbtk_interp->result); + return val; +} + + +static void +gdbtk_print_frame_info (s, line, stopline, noerror) + struct symtab *s; + int line; + int stopline; + int noerror; +{ + current_source_symtab = s; + current_source_line = line; +} + +static void +gdbtk_create_tracepoint (tp) + struct tracepoint *tp; +{ + tracepoint_notify (tp, "create"); +} + +static void +gdbtk_delete_tracepoint (tp) + struct tracepoint *tp; +{ + tracepoint_notify (tp, "delete"); +} + +static void +gdbtk_modify_tracepoint (tp) + struct tracepoint *tp; +{ + tracepoint_notify (tp, "modify"); +} + +static void +tracepoint_notify(tp, action) + struct tracepoint *tp; + const char *action; +{ + char buf[256]; + int v; + struct symtab_and_line sal; + char *filename; + + /* We ensure that ACTION contains no special Tcl characters, so we + can do this. */ + sal = find_pc_line (tp->address, 0); + + filename = symtab_to_filename (sal.symtab); + if (filename == NULL) + filename = "N/A"; + sprintf (buf, "gdbtk_tcl_tracepoint %s %d 0x%lx %d {%s}", action, tp->number, + (long)tp->address, sal.line, filename, tp->pass_count); + + v = Tcl_Eval (gdbtk_interp, buf); + + if (v != TCL_OK) + { + gdbtk_fputs (gdbtk_interp->result, gdb_stdout); + gdbtk_fputs ("\n", gdb_stdout); + } +} + + |