1 /* Tcl/Tk interface routines.
2 Copyright 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
4 Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
6 This file is part of GDB.
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program; if not, write to the Free Software
20 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
31 #include "tracepoint.h"
47 /* start-sanitize-ide */
51 /* end-sanitize-ide */
54 #ifdef ANSI_PROTOTYPES
64 #include <sys/ioctl.h>
65 #include "gdb_string.h"
74 #define GDBTK_PATH_SEP ";"
76 #define GDBTK_PATH_SEP ":"
79 /* Some versions (1.3.79, 1.3.81) of Linux don't support SIOCSPGRP the way
80 gdbtk wants to use it... */
85 static int No_Update
= 0;
86 static int load_in_progress
= 0;
87 static int in_fputs
= 0;
89 int gdbtk_load_hash
PARAMS ((char *, unsigned long));
90 int (*ui_load_progress_hook
) PARAMS ((char *, unsigned long));
91 void (*pre_add_symbol_hook
) PARAMS ((char *));
92 void (*post_add_symbol_hook
) PARAMS ((void));
94 char * get_prompt
PARAMS ((void));
96 static void null_routine
PARAMS ((int));
97 static void gdbtk_flush
PARAMS ((FILE *));
98 static void gdbtk_fputs
PARAMS ((const char *, FILE *));
99 static int gdbtk_query
PARAMS ((const char *, va_list));
100 static void gdbtk_warning
PARAMS ((const char *, va_list));
101 static void gdbtk_ignorable_warning
PARAMS ((const char *, va_list));
102 static char *gdbtk_readline
PARAMS ((char *));
103 static void gdbtk_init
PARAMS ((char *));
104 static void tk_command_loop
PARAMS ((void));
105 static void gdbtk_call_command
PARAMS ((struct cmd_list_element
*, char *, int));
106 static int gdbtk_wait
PARAMS ((int, struct target_waitstatus
*));
107 static void x_event
PARAMS ((int));
108 static void gdbtk_interactive
PARAMS ((void));
109 static void cleanup_init
PARAMS ((int));
110 static void tk_command
PARAMS ((char *, int));
111 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
112 static int compare_lines
PARAMS ((const PTR
, const PTR
));
113 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
114 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
115 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
116 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
117 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
118 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
119 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
120 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
121 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
122 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
123 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
124 static void gdbtk_readline_end
PARAMS ((void));
125 static void pc_changed
PARAMS ((void));
126 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
127 static void register_changed_p
PARAMS ((int, void *));
128 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
129 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
130 static void breakpoint_notify
PARAMS ((struct breakpoint
*, const char *));
131 static void gdbtk_create_breakpoint
PARAMS ((struct breakpoint
*));
132 static void gdbtk_delete_breakpoint
PARAMS ((struct breakpoint
*));
133 static void gdbtk_modify_breakpoint
PARAMS ((struct breakpoint
*));
134 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
135 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
136 static int map_arg_registers
PARAMS ((int, char *[], void (*) (int, void *), void *));
137 static void get_register_name
PARAMS ((int, void *));
138 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
139 static void get_register
PARAMS ((int, void *));
140 static int gdb_trace_status
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
141 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
142 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
143 void TclDebug
PARAMS ((const char *fmt
, ...));
144 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
145 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
146 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
147 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
148 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
149 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
150 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
151 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
152 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
153 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
154 static void gdbtk_create_tracepoint
PARAMS ((struct tracepoint
*));
155 static void gdbtk_delete_tracepoint
PARAMS ((struct tracepoint
*));
156 static void gdbtk_modify_tracepoint
PARAMS ((struct tracepoint
*));
157 static void tracepoint_notify
PARAMS ((struct tracepoint
*, const char *));
158 static void gdbtk_print_frame_info
PARAMS ((struct symtab
*, int, int, int));
159 void gdbtk_pre_add_symbol
PARAMS ((char *));
160 void gdbtk_post_add_symbol
PARAMS ((void));
161 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
162 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
163 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
164 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
165 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
167 /* Handle for TCL interpreter */
168 static Tcl_Interp
*interp
= NULL
;
170 static int gdbtk_timer_going
= 0;
171 static void gdbtk_start_timer
PARAMS ((void));
172 static void gdbtk_stop_timer
PARAMS ((void));
174 /* This variable is true when the inferior is running. Although it's
175 possible to disable most input from widgets and thus prevent
176 attempts to do anything while the inferior is running, any commands
177 that get through - even a simple memory read - are Very Bad, and
178 may cause GDB to crash or behave strangely. So, this variable
179 provides an extra layer of defense. */
181 static int running_now
;
183 /* This variable determines where memory used for disassembly is read from.
184 If > 0, then disassembly comes from the exec file rather than the
185 target (which might be at the other end of a slow serial link). If
186 == 0 then disassembly comes from target. If < 0 disassembly is
187 automatically switched to the target if it's an inferior process,
188 otherwise the exec file is used. */
190 static int disassemble_from_exec
= -1;
194 /* Supply malloc calls for tcl/tk. We do not want to do this on
195 Windows, because Tcl_Alloc is probably in a DLL which will not call
196 the mmalloc routines. */
202 return xmalloc (size
);
206 Tcl_Realloc (ptr
, size
)
210 return xrealloc (ptr
, size
);
220 #endif /* ! _WIN32 */
230 /* On Windows, if we hold a file open, other programs can't write to
231 it. In particular, we don't want to hold the executable open,
232 because it will mean that people have to get out of the debugging
233 session in order to remake their program. So we close it, although
234 this will cost us if and when we need to reopen it. */
244 bfd_cache_close (o
->obfd
);
247 if (exec_bfd
!= NULL
)
248 bfd_cache_close (exec_bfd
);
253 /* The following routines deal with stdout/stderr data, which is created by
254 {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the
255 lowest level of these routines and capture all output from the rest of GDB.
256 Normally they present their data to tcl via callbacks to the following tcl
257 routines: gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush. These
258 in turn call tk routines to update the display.
260 Under some circumstances, you may want to collect the output so that it can
261 be returned as the value of a tcl procedure. This can be done by
262 surrounding the output routines with calls to start_saving_output and
263 finish_saving_output. The saved data can then be retrieved with
264 get_saved_output (but this must be done before the call to
265 finish_saving_output). */
267 /* Dynamic string for output. */
269 static Tcl_DString
*result_ptr
;
271 /* Dynamic string for stderr. This is only used if result_ptr is
274 static Tcl_DString
*error_string_ptr
;
281 /* Force immediate screen update */
283 Tcl_VarEval (interp
, "gdbtk_tcl_flush", NULL
);
288 gdbtk_fputs (ptr
, stream
)
292 char *merge
[2], *command
;
296 Tcl_DStringAppend (result_ptr
, (char *) ptr
, -1);
297 else if (error_string_ptr
!= NULL
&& stream
== gdb_stderr
)
298 Tcl_DStringAppend (error_string_ptr
, (char *) ptr
, -1);
301 merge
[0] = "gdbtk_tcl_fputs";
302 merge
[1] = (char *)ptr
;
303 command
= Tcl_Merge (2, merge
);
304 Tcl_Eval (interp
, command
);
311 gdbtk_warning (warning
, args
)
315 char buf
[200], *merge
[2];
318 vsprintf (buf
, warning
, args
);
319 merge
[0] = "gdbtk_tcl_warning";
321 command
= Tcl_Merge (2, merge
);
322 Tcl_Eval (interp
, command
);
327 gdbtk_ignorable_warning (warning
, args
)
331 char buf
[200], *merge
[2];
334 vsprintf (buf
, warning
, args
);
335 merge
[0] = "gdbtk_tcl_ignorable_warning";
337 command
= Tcl_Merge (2, merge
);
338 Tcl_Eval (interp
, command
);
343 gdbtk_query (query
, args
)
347 char buf
[200], *merge
[2];
351 vsprintf (buf
, query
, args
);
352 merge
[0] = "gdbtk_tcl_query";
354 command
= Tcl_Merge (2, merge
);
355 Tcl_Eval (interp
, command
);
358 val
= atol (interp
->result
);
364 #ifdef ANSI_PROTOTYPES
365 gdbtk_readline_begin (char *format
, ...)
367 gdbtk_readline_begin (va_alist
)
372 char buf
[200], *merge
[2];
375 #ifdef ANSI_PROTOTYPES
376 va_start (args
, format
);
380 format
= va_arg (args
, char *);
383 vsprintf (buf
, format
, args
);
384 merge
[0] = "gdbtk_tcl_readline_begin";
386 command
= Tcl_Merge (2, merge
);
387 Tcl_Eval (interp
, command
);
392 gdbtk_readline (prompt
)
403 merge
[0] = "gdbtk_tcl_readline";
405 command
= Tcl_Merge (2, merge
);
406 result
= Tcl_Eval (interp
, command
);
408 if (result
== TCL_OK
)
410 return (strdup (interp
-> result
));
414 gdbtk_fputs (interp
-> result
, gdb_stdout
);
415 gdbtk_fputs ("\n", gdb_stdout
);
421 gdbtk_readline_end ()
423 Tcl_Eval (interp
, "gdbtk_tcl_readline_end");
429 Tcl_Eval (interp
, "gdbtk_pc_changed");
434 #ifdef ANSI_PROTOTYPES
435 dsprintf_append_element (Tcl_DString
*dsp
, char *format
, ...)
437 dsprintf_append_element (va_alist
)
444 #ifdef ANSI_PROTOTYPES
445 va_start (args
, format
);
451 dsp
= va_arg (args
, Tcl_DString
*);
452 format
= va_arg (args
, char *);
455 vsprintf (buf
, format
, args
);
457 Tcl_DStringAppendElement (dsp
, buf
);
461 gdb_path_conv (clientData
, interp
, argc
, argv
)
462 ClientData clientData
;
468 char pathname
[256], *ptr
;
470 error ("wrong # args");
471 cygwin32_conv_to_full_win32_path (argv
[1], pathname
);
472 for (ptr
= pathname
; *ptr
; ptr
++)
478 char *pathname
= argv
[1];
480 Tcl_DStringAppend (result_ptr
, pathname
, strlen(pathname
));
485 gdb_get_breakpoint_list (clientData
, interp
, argc
, argv
)
486 ClientData clientData
;
491 struct breakpoint
*b
;
492 extern struct breakpoint
*breakpoint_chain
;
495 error ("wrong # args");
497 for (b
= breakpoint_chain
; b
; b
= b
->next
)
498 if (b
->type
== bp_breakpoint
)
499 dsprintf_append_element (result_ptr
, "%d", b
->number
);
505 gdb_get_breakpoint_info (clientData
, interp
, argc
, argv
)
506 ClientData clientData
;
511 struct symtab_and_line sal
;
512 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
513 "finish", "watchpoint", "hardware watchpoint",
514 "read watchpoint", "access watchpoint",
515 "longjmp", "longjmp resume", "step resume",
516 "through sigtramp", "watchpoint scope",
518 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
519 struct command_line
*cmd
;
521 struct breakpoint
*b
;
522 extern struct breakpoint
*breakpoint_chain
;
523 char *funcname
, *fname
, *filename
;
526 error ("wrong # args");
528 bpnum
= atoi (argv
[1]);
530 for (b
= breakpoint_chain
; b
; b
= b
->next
)
531 if (b
->number
== bpnum
)
534 if (!b
|| b
->type
!= bp_breakpoint
)
535 error ("Breakpoint #%d does not exist", bpnum
);
537 sal
= find_pc_line (b
->address
, 0);
539 filename
= symtab_to_filename (sal
.symtab
);
540 if (filename
== NULL
)
542 Tcl_DStringAppendElement (result_ptr
, filename
);
544 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
545 fname
= cplus_demangle (funcname
, 0);
548 Tcl_DStringAppendElement (result_ptr
, fname
);
552 Tcl_DStringAppendElement (result_ptr
, funcname
);
553 dsprintf_append_element (result_ptr
, "%d", b
->line_number
);
554 dsprintf_append_element (result_ptr
, "0x%lx", b
->address
);
555 Tcl_DStringAppendElement (result_ptr
, bptypes
[b
->type
]);
556 Tcl_DStringAppendElement (result_ptr
, b
->enable
== enabled
? "1" : "0");
557 Tcl_DStringAppendElement (result_ptr
, bpdisp
[b
->disposition
]);
558 dsprintf_append_element (result_ptr
, "%d", b
->ignore_count
);
560 Tcl_DStringStartSublist (result_ptr
);
561 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
562 Tcl_DStringAppendElement (result_ptr
, cmd
->line
);
563 Tcl_DStringEndSublist (result_ptr
);
565 Tcl_DStringAppendElement (result_ptr
, b
->cond_string
);
567 dsprintf_append_element (result_ptr
, "%d", b
->thread
);
568 dsprintf_append_element (result_ptr
, "%d", b
->hit_count
);
574 breakpoint_notify(b
, action
)
575 struct breakpoint
*b
;
580 struct symtab_and_line sal
;
583 if (b
->type
!= bp_breakpoint
)
586 /* We ensure that ACTION contains no special Tcl characters, so we
588 sal
= find_pc_line (b
->address
, 0);
589 filename
= symtab_to_filename (sal
.symtab
);
590 if (filename
== NULL
)
593 sprintf (buf
, "gdbtk_tcl_breakpoint %s %d 0x%lx %d {%s}", action
, b
->number
,
594 (long)b
->address
, b
->line_number
, filename
);
596 v
= Tcl_Eval (interp
, buf
);
600 gdbtk_fputs (interp
->result
, gdb_stdout
);
601 gdbtk_fputs ("\n", gdb_stdout
);
606 gdbtk_create_breakpoint(b
)
607 struct breakpoint
*b
;
609 breakpoint_notify (b
, "create");
613 gdbtk_delete_breakpoint(b
)
614 struct breakpoint
*b
;
616 breakpoint_notify (b
, "delete");
620 gdbtk_modify_breakpoint(b
)
621 struct breakpoint
*b
;
623 breakpoint_notify (b
, "modify");
626 /* This implements the TCL command `gdb_loc', which returns a list */
627 /* consisting of the following: */
628 /* basename, function name, filename, line number, address, current pc */
631 gdb_loc (clientData
, interp
, argc
, argv
)
632 ClientData clientData
;
638 struct symtab_and_line sal
;
639 char *funcname
, *fname
;
642 if (!have_full_symbols () && !have_partial_symbols ())
644 Tcl_SetResult (interp
, "No symbol table is loaded", TCL_STATIC
);
650 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
652 /* Note - this next line is not correct on all architectures. */
653 /* For a graphical debugged we really want to highlight the */
654 /* assembly line that called the next function on the stack. */
655 /* Many architectures have the next instruction saved as the */
656 /* pc on the stack, so what happens is the next instruction is hughlighted. */
658 pc
= selected_frame
->pc
;
659 sal
= find_pc_line (selected_frame
->pc
,
660 selected_frame
->next
!= NULL
661 && !selected_frame
->next
->signal_handler_caller
662 && !frame_in_dummy (selected_frame
->next
));
667 sal
= find_pc_line (stop_pc
, 0);
672 struct symtabs_and_lines sals
;
675 sals
= decode_line_spec (argv
[1], 1);
682 error ("Ambiguous line spec");
687 error ("wrong # args");
690 Tcl_DStringAppendElement (result_ptr
, sal
.symtab
->filename
);
692 Tcl_DStringAppendElement (result_ptr
, "");
694 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
695 fname
= cplus_demangle (funcname
, 0);
698 Tcl_DStringAppendElement (result_ptr
, fname
);
702 Tcl_DStringAppendElement (result_ptr
, funcname
);
703 filename
= symtab_to_filename (sal
.symtab
);
704 if (filename
== NULL
)
707 Tcl_DStringAppendElement (result_ptr
, filename
);
708 dsprintf_append_element (result_ptr
, "%d", sal
.line
); /* line number */
709 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
710 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
714 /* This implements the TCL command `gdb_eval'. */
717 gdb_eval (clientData
, interp
, argc
, argv
)
718 ClientData clientData
;
723 struct expression
*expr
;
724 struct cleanup
*old_chain
;
728 error ("wrong # args");
730 expr
= parse_expression (argv
[1]);
732 old_chain
= make_cleanup (free_current_contents
, &expr
);
734 val
= evaluate_expression (expr
);
736 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
737 gdb_stdout
, 0, 0, 0, 0);
739 do_cleanups (old_chain
);
744 /* gdb_get_mem addr form size num aschar*/
745 /* dump a block of memory */
746 /* addr: address of data to dump */
747 /* form: a char indicating format */
748 /* size: size of each element; 1,2,4, or 8 bytes*/
749 /* num: the number of bytes to read */
750 /* acshar: an optional ascii character to use in ASCII dump */
751 /* returns a list of elements followed by an optional */
755 gdb_get_mem (clientData
, interp
, argc
, argv
)
756 ClientData clientData
;
761 int size
, asize
, i
, j
, bc
;
763 int nbytes
, rnum
, bpr
;
764 char format
, c
, *ptr
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
765 struct type
*val_type
;
767 if (argc
< 6 || argc
> 7)
769 interp
->result
= "addr format size bytes bytes_per_row ?ascii_char?";
773 size
= (int)strtoul(argv
[3],(char **)NULL
,0);
774 nbytes
= (int)strtoul(argv
[4],(char **)NULL
,0);
775 bpr
= (int)strtoul(argv
[5],(char **)NULL
,0);
776 if (nbytes
<= 0 || bpr
<= 0 || size
<= 0)
778 interp
->result
= "Invalid number of bytes.";
782 addr
= (CORE_ADDR
)strtoul(argv
[1],(char **)NULL
,0);
784 mbuf
= (char *)malloc (nbytes
+32);
787 interp
->result
= "Out of memory.";
790 memset (mbuf
, 0, nbytes
+32);
793 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
802 val_type
= builtin_type_char
;
806 val_type
= builtin_type_short
;
810 val_type
= builtin_type_int
;
814 val_type
= builtin_type_long_long
;
818 val_type
= builtin_type_char
;
822 bc
= 0; /* count of bytes in a row */
823 buff
[0] = '"'; /* buffer for ascii dump */
824 bptr
= &buff
[1]; /* pointer for ascii dump */
826 for (i
=0; i
< nbytes
; i
+= size
)
830 fputs_unfiltered ("N/A ", gdb_stdout
);
832 for ( j
= 0; j
< size
; j
++)
837 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
838 fputs_unfiltered (" ", gdb_stdout
);
841 for ( j
= 0; j
< size
; j
++)
844 if (c
< 32 || c
> 126)
856 if (aschar
&& (bc
>= bpr
))
858 /* end of row. print it and reset variables */
863 fputs_unfiltered (buff
, gdb_stdout
);
873 map_arg_registers (argc
, argv
, func
, argp
)
876 void (*func
) PARAMS ((int regnum
, void *argp
));
881 /* Note that the test for a valid register must include checking the
882 reg_names array because NUM_REGS may be allocated for the union of the
883 register sets within a family of related processors. In this case, the
884 trailing entries of reg_names will change depending upon the particular
885 processor being debugged. */
887 if (argc
== 0) /* No args, just do all the regs */
891 && reg_names
[regnum
] != NULL
892 && *reg_names
[regnum
] != '\000';
899 /* Else, list of register #s, just do listed regs */
900 for (; argc
> 0; argc
--, argv
++)
902 regnum
= atoi (*argv
);
906 && reg_names
[regnum
] != NULL
907 && *reg_names
[regnum
] != '\000')
910 error ("bad register number");
917 get_register_name (regnum
, argp
)
919 void *argp
; /* Ignored */
921 Tcl_DStringAppendElement (result_ptr
, reg_names
[regnum
]);
924 /* This implements the TCL command `gdb_regnames', which returns a list of
925 all of the register names. */
928 gdb_regnames (clientData
, interp
, argc
, argv
)
929 ClientData clientData
;
937 return map_arg_registers (argc
, argv
, get_register_name
, NULL
);
940 #ifndef REGISTER_CONVERTIBLE
941 #define REGISTER_CONVERTIBLE(x) (0 != 0)
944 #ifndef REGISTER_CONVERT_TO_VIRTUAL
945 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
948 #ifndef INVALID_FLOAT
949 #define INVALID_FLOAT(x, y) (0 != 0)
953 get_register (regnum
, fp
)
957 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
958 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
959 int format
= (int)fp
;
964 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
966 Tcl_DStringAppendElement (result_ptr
, "Optimized out");
970 /* Convert raw data to virtual format if necessary. */
972 if (REGISTER_CONVERTIBLE (regnum
))
974 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
975 raw_buffer
, virtual_buffer
);
978 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
983 printf_filtered ("0x");
984 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
986 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
987 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
988 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
992 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
993 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
995 Tcl_DStringAppend (result_ptr
, " ", -1);
999 get_pc_register (clientData
, interp
, argc
, argv
)
1000 ClientData clientData
;
1005 sprintf(interp
->result
,"0x%llx",(long long)read_register(PC_REGNUM
));
1010 gdb_fetch_registers (clientData
, interp
, argc
, argv
)
1011 ClientData clientData
;
1019 error ("wrong # args");
1025 return map_arg_registers (argc
, argv
, get_register
, (void *) format
);
1028 /* This contains the previous values of the registers, since the last call to
1029 gdb_changed_register_list. */
1031 static char old_regs
[REGISTER_BYTES
];
1034 register_changed_p (regnum
, argp
)
1036 void *argp
; /* Ignored */
1038 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1040 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1043 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1044 REGISTER_RAW_SIZE (regnum
)) == 0)
1047 /* Found a changed register. Save new value and return its number. */
1049 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1050 REGISTER_RAW_SIZE (regnum
));
1052 dsprintf_append_element (result_ptr
, "%d", regnum
);
1056 gdb_changed_register_list (clientData
, interp
, argc
, argv
)
1057 ClientData clientData
;
1065 return map_arg_registers (argc
, argv
, register_changed_p
, NULL
);
1068 /* This implements the tcl command "gdb_immediate", which does exactly
1069 the same thing as gdb_cmd, except NONE of its outut is buffered. */
1070 /* This will also ALWAYS cause the busy,update, and idle hooks to be
1071 called, contrasted with gdb_cmd, which NEVER calls them. */
1073 gdb_immediate_command (clientData
, interp
, argc
, argv
)
1074 ClientData clientData
;
1079 Tcl_DString
*save_ptr
= NULL
;
1082 error ("wrong # args");
1084 if (running_now
|| load_in_progress
)
1089 Tcl_DStringAppend (result_ptr
, "", -1);
1090 save_ptr
= result_ptr
;
1093 execute_command (argv
[1], 1);
1095 bpstat_do_actions (&stop_bpstat
);
1097 result_ptr
= save_ptr
;
1102 /* This implements the TCL command `gdb_cmd', which sends its argument into
1103 the GDB command scanner. */
1104 /* This command will never cause the update, idle and busy hooks to be called
1107 gdb_cmd (clientData
, interp
, argc
, argv
)
1108 ClientData clientData
;
1113 Tcl_DString
*save_ptr
= NULL
;
1116 error ("wrong # args");
1118 if (running_now
|| load_in_progress
)
1123 /* for the load instruction (and possibly others later) we
1124 set result_ptr to NULL so gdbtk_fputs() will not buffer
1125 all the data until the command is finished. */
1127 if (strncmp ("load ", argv
[1], 5) == 0
1128 || strncmp ("while ", argv
[1], 6) == 0)
1130 Tcl_DStringAppend (result_ptr
, "", -1);
1131 save_ptr
= result_ptr
;
1133 load_in_progress
= 1;
1134 gdbtk_start_timer ();
1137 execute_command (argv
[1], 1);
1139 if (load_in_progress
)
1141 gdbtk_stop_timer ();
1142 load_in_progress
= 0;
1145 bpstat_do_actions (&stop_bpstat
);
1148 result_ptr
= save_ptr
;
1153 /* Client of call_wrapper - this routine performs the actual call to
1154 the client function. */
1156 struct wrapped_call_args
1167 struct wrapped_call_args
*args
;
1169 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->argc
, args
->argv
);
1173 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
1174 handles cleanups, and calls to return_to_top_level (usually via error).
1175 This is necessary in order to prevent a longjmp out of the bowels of Tk,
1176 possibly leaving things in a bad state. Since this routine can be called
1177 recursively, it needs to save and restore the contents of the jmp_buf as
1181 call_wrapper (clientData
, interp
, argc
, argv
)
1182 ClientData clientData
;
1187 struct wrapped_call_args wrapped_args
;
1188 Tcl_DString result
, *old_result_ptr
;
1189 Tcl_DString error_string
, *old_error_string_ptr
;
1191 Tcl_DStringInit (&result
);
1192 old_result_ptr
= result_ptr
;
1193 result_ptr
= &result
;
1195 Tcl_DStringInit (&error_string
);
1196 old_error_string_ptr
= error_string_ptr
;
1197 error_string_ptr
= &error_string
;
1199 wrapped_args
.func
= (Tcl_CmdProc
*)clientData
;
1200 wrapped_args
.interp
= interp
;
1201 wrapped_args
.argc
= argc
;
1202 wrapped_args
.argv
= argv
;
1203 wrapped_args
.val
= 0;
1205 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
1207 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
1209 /* Make sure the timer interrupts are turned off. */
1210 if (gdbtk_timer_going
)
1211 gdbtk_stop_timer ();
1213 gdb_flush (gdb_stderr
); /* Flush error output */
1214 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
1216 /* In case of an error, we may need to force the GUI into idle
1217 mode because gdbtk_call_command may have bombed out while in
1218 the command routine. */
1221 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1224 /* do not suppress any errors -- a remote target could have errored */
1225 load_in_progress
= 0;
1227 if (Tcl_DStringLength (&error_string
) == 0)
1229 Tcl_DStringResult (interp
, &result
);
1230 Tcl_DStringFree (&error_string
);
1232 else if (Tcl_DStringLength (&result
) == 0)
1234 Tcl_DStringResult (interp
, &error_string
);
1235 Tcl_DStringFree (&result
);
1236 Tcl_DStringFree (&error_string
);
1240 Tcl_ResetResult (interp
);
1241 Tcl_AppendResult (interp
, Tcl_DStringValue (&result
),
1242 Tcl_DStringValue (&error_string
), (char *) NULL
);
1243 Tcl_DStringFree (&result
);
1244 Tcl_DStringFree (&error_string
);
1247 result_ptr
= old_result_ptr
;
1248 error_string_ptr
= old_error_string_ptr
;
1254 return wrapped_args
.val
;
1258 comp_files (file1
, file2
)
1259 const char *file1
[], *file2
[];
1261 return strcmp(*file1
,*file2
);
1265 gdb_listfiles (clientData
, interp
, objc
, objv
)
1266 ClientData clientData
;
1269 Tcl_Obj
*CONST objv
[];
1271 struct objfile
*objfile
;
1272 struct partial_symtab
*psymtab
;
1273 struct symtab
*symtab
;
1274 char *lastfile
, *pathname
, **files
;
1276 int i
, numfiles
= 0, len
= 0;
1280 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1284 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1288 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1290 mylist
= Tcl_NewListObj (0, NULL
);
1292 ALL_PSYMTABS (objfile
, psymtab
)
1294 if (numfiles
== files_size
)
1296 files_size
= files_size
* 2;
1297 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1301 if (psymtab
->filename
)
1302 files
[numfiles
++] = basename(psymtab
->filename
);
1304 else if (!strcmp(psymtab
->filename
,basename(psymtab
->filename
))
1305 || !strncmp(pathname
,psymtab
->filename
,len
))
1306 if (psymtab
->filename
)
1307 files
[numfiles
++] = basename(psymtab
->filename
);
1310 ALL_SYMTABS (objfile
, symtab
)
1312 if (numfiles
== files_size
)
1314 files_size
= files_size
* 2;
1315 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1319 if (symtab
->filename
)
1320 files
[numfiles
++] = basename(symtab
->filename
);
1322 else if (!strcmp(symtab
->filename
,basename(symtab
->filename
))
1323 || !strncmp(pathname
,symtab
->filename
,len
))
1324 if (symtab
->filename
)
1325 files
[numfiles
++] = basename(symtab
->filename
);
1328 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1331 for (i
= 0; i
< numfiles
; i
++)
1333 if (strcmp(files
[i
],lastfile
))
1334 Tcl_ListObjAppendElement (interp
, mylist
, Tcl_NewStringObj(files
[i
], -1));
1335 lastfile
= files
[i
];
1337 Tcl_SetObjResult (interp
, mylist
);
1343 gdb_listfuncs (clientData
, interp
, argc
, argv
)
1344 ClientData clientData
;
1349 struct symtab
*symtab
;
1350 struct blockvector
*bv
;
1357 error ("wrong # args");
1359 symtab
= full_lookup_symtab (argv
[1]);
1361 error ("No such file");
1363 bv
= BLOCKVECTOR (symtab
);
1364 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1366 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1367 /* Skip the sort if this block is always sorted. */
1368 if (!BLOCK_SHOULD_SORT (b
))
1369 sort_block_syms (b
);
1370 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1372 sym
= BLOCK_SYM (b
, j
);
1373 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1376 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1379 sprintf (buf
,"{%s} 1", name
);
1382 sprintf (buf
,"{%s} 0", SYMBOL_NAME(sym
));
1383 Tcl_DStringAppendElement (result_ptr
, buf
);
1391 target_stop_wrapper (args
)
1399 gdb_stop (clientData
, interp
, argc
, argv
)
1400 ClientData clientData
;
1407 catch_errors (target_stop_wrapper
, NULL
, "",
1411 quit_flag
= 1; /* hope something sees this */
1416 /* Prepare to accept a new executable file. This is called when we
1417 want to clear away everything we know about the old file, without
1418 asking the user. The Tcl code will have already asked the user if
1419 necessary. After this is called, we should be able to run the
1420 `file' command without getting any questions. */
1423 gdb_clear_file (clientData
, interp
, argc
, argv
)
1424 ClientData clientData
;
1429 if (inferior_pid
!= 0 && target_has_execution
)
1432 target_detach (NULL
, 0);
1437 if (target_has_execution
)
1440 symbol_file_command (NULL
, 0);
1442 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
1443 clear it here. FIXME: This seems like an abstraction violation
1450 /* Ask the user to confirm an exit request. */
1453 gdb_confirm_quit (clientData
, interp
, argc
, argv
)
1454 ClientData clientData
;
1461 ret
= quit_confirm ();
1462 Tcl_DStringAppendElement (result_ptr
, ret
? "1" : "0");
1466 /* Quit without asking for confirmation. */
1469 gdb_force_quit (clientData
, interp
, argc
, argv
)
1470 ClientData clientData
;
1475 quit_force ((char *) NULL
, 1);
1479 /* This implements the TCL command `gdb_disassemble'. */
1482 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
1486 disassemble_info
*info
;
1488 extern struct target_ops exec_ops
;
1492 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
1503 /* We need a different sort of line table from the normal one cuz we can't
1504 depend upon implicit line-end pc's for lines. This is because of the
1505 reordering we are about to do. */
1507 struct my_line_entry
{
1514 compare_lines (mle1p
, mle2p
)
1518 struct my_line_entry
*mle1
, *mle2
;
1521 mle1
= (struct my_line_entry
*) mle1p
;
1522 mle2
= (struct my_line_entry
*) mle2p
;
1524 val
= mle1
->line
- mle2
->line
;
1529 return mle1
->start_pc
- mle2
->start_pc
;
1533 gdb_disassemble (clientData
, interp
, argc
, argv
)
1534 ClientData clientData
;
1539 CORE_ADDR pc
, low
, high
;
1540 int mixed_source_and_assembly
;
1541 static disassemble_info di
;
1542 static int di_initialized
;
1544 if (! di_initialized
)
1546 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
1547 (fprintf_ftype
) fprintf_unfiltered
);
1548 di
.flavour
= bfd_target_unknown_flavour
;
1549 di
.memory_error_func
= dis_asm_memory_error
;
1550 di
.print_address_func
= dis_asm_print_address
;
1554 di
.mach
= tm_print_insn_info
.mach
;
1555 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
1556 di
.endian
= BFD_ENDIAN_BIG
;
1558 di
.endian
= BFD_ENDIAN_LITTLE
;
1560 if (argc
!= 3 && argc
!= 4)
1561 error ("wrong # args");
1563 if (strcmp (argv
[1], "source") == 0)
1564 mixed_source_and_assembly
= 1;
1565 else if (strcmp (argv
[1], "nosource") == 0)
1566 mixed_source_and_assembly
= 0;
1568 error ("First arg must be 'source' or 'nosource'");
1570 low
= parse_and_eval_address (argv
[2]);
1574 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
1575 error ("No function contains specified address");
1578 high
= parse_and_eval_address (argv
[3]);
1580 /* If disassemble_from_exec == -1, then we use the following heuristic to
1581 determine whether or not to do disassembly from target memory or from the
1584 If we're debugging a local process, read target memory, instead of the
1585 exec file. This makes disassembly of functions in shared libs work
1588 Else, we're debugging a remote process, and should disassemble from the
1589 exec file for speed. However, this is no good if the target modifies its
1590 code (for relocation, or whatever).
1593 if (disassemble_from_exec
== -1)
1594 if (strcmp (target_shortname
, "child") == 0
1595 || strcmp (target_shortname
, "procfs") == 0
1596 || strcmp (target_shortname
, "vxprocess") == 0)
1597 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
1599 disassemble_from_exec
= 1; /* It's remote, read the exec file */
1601 if (disassemble_from_exec
)
1602 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
1604 di
.read_memory_func
= dis_asm_read_memory
;
1606 /* If just doing straight assembly, all we need to do is disassemble
1607 everything between low and high. If doing mixed source/assembly, we've
1608 got a totally different path to follow. */
1610 if (mixed_source_and_assembly
)
1611 { /* Come here for mixed source/assembly */
1612 /* The idea here is to present a source-O-centric view of a function to
1613 the user. This means that things are presented in source order, with
1614 (possibly) out of order assembly immediately following. */
1615 struct symtab
*symtab
;
1616 struct linetable_entry
*le
;
1619 struct my_line_entry
*mle
;
1620 struct symtab_and_line sal
;
1625 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
1630 /* First, convert the linetable to a bunch of my_line_entry's. */
1632 le
= symtab
->linetable
->item
;
1633 nlines
= symtab
->linetable
->nitems
;
1638 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
1642 /* Copy linetable entries for this function into our data structure, creating
1643 end_pc's and setting out_of_order as appropriate. */
1645 /* First, skip all the preceding functions. */
1647 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
1649 /* Now, copy all entries before the end of this function. */
1652 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
1654 if (le
[i
].line
== le
[i
+ 1].line
1655 && le
[i
].pc
== le
[i
+ 1].pc
)
1656 continue; /* Ignore duplicates */
1658 mle
[newlines
].line
= le
[i
].line
;
1659 if (le
[i
].line
> le
[i
+ 1].line
)
1661 mle
[newlines
].start_pc
= le
[i
].pc
;
1662 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
1666 /* If we're on the last line, and it's part of the function, then we need to
1667 get the end pc in a special way. */
1672 mle
[newlines
].line
= le
[i
].line
;
1673 mle
[newlines
].start_pc
= le
[i
].pc
;
1674 sal
= find_pc_line (le
[i
].pc
, 0);
1675 mle
[newlines
].end_pc
= sal
.end
;
1679 /* Now, sort mle by line #s (and, then by addresses within lines). */
1682 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
1684 /* Now, for each line entry, emit the specified lines (unless they have been
1685 emitted before), followed by the assembly code for that line. */
1687 next_line
= 0; /* Force out first line */
1688 for (i
= 0; i
< newlines
; i
++)
1690 /* Print out everything from next_line to the current line. */
1692 if (mle
[i
].line
>= next_line
)
1695 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
1697 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
1699 next_line
= mle
[i
].line
+ 1;
1702 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
1705 fputs_unfiltered (" ", gdb_stdout
);
1706 print_address (pc
, gdb_stdout
);
1707 fputs_unfiltered (":\t ", gdb_stdout
);
1708 pc
+= (*tm_print_insn
) (pc
, &di
);
1709 fputs_unfiltered ("\n", gdb_stdout
);
1716 for (pc
= low
; pc
< high
; )
1719 fputs_unfiltered (" ", gdb_stdout
);
1720 print_address (pc
, gdb_stdout
);
1721 fputs_unfiltered (":\t ", gdb_stdout
);
1722 pc
+= (*tm_print_insn
) (pc
, &di
);
1723 fputs_unfiltered ("\n", gdb_stdout
);
1727 gdb_flush (gdb_stdout
);
1733 tk_command (cmd
, from_tty
)
1739 struct cleanup
*old_chain
;
1741 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1743 error_no_arg ("tcl command to interpret");
1745 retval
= Tcl_Eval (interp
, cmd
);
1747 result
= strdup (interp
->result
);
1749 old_chain
= make_cleanup (free
, result
);
1751 if (retval
!= TCL_OK
)
1754 printf_unfiltered ("%s\n", result
);
1756 do_cleanups (old_chain
);
1760 cleanup_init (ignored
)
1764 Tcl_DeleteInterp (interp
);
1768 /* Come here during long calculations to check for GUI events. Usually invoked
1769 via the QUIT macro. */
1772 gdbtk_interactive ()
1774 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1777 /* Come here when there is activity on the X file descriptor. */
1783 static int in_x_event
= 0;
1784 static Tcl_Obj
*varname
= NULL
;
1785 if (in_x_event
|| in_fputs
)
1790 /* Process pending events */
1791 while (Tcl_DoOneEvent (TCL_DONT_WAIT
|TCL_ALL_EVENTS
) != 0)
1794 if (load_in_progress
)
1797 if (varname
== NULL
)
1799 Tcl_Obj
*varnamestrobj
= Tcl_NewStringObj("download_cancel_ok",-1);
1800 varname
= Tcl_ObjGetVar2(interp
,varnamestrobj
,NULL
,TCL_GLOBAL_ONLY
);
1802 if ((Tcl_GetIntFromObj(interp
,varname
,&val
) == TCL_OK
) && val
)
1816 /* For Cygwin32, we use a timer to periodically check for Windows
1817 messages. FIXME: It would be better to not poll, but to instead
1818 rewrite the target_wait routines to serve as input sources.
1819 Unfortunately, that will be a lot of work. */
1820 static sigset_t nullsigmask
;
1821 static struct sigaction act1
, act2
;
1822 static struct itimerval it_on
, it_off
;
1825 gdbtk_start_timer ()
1827 static int first
= 1;
1828 /*TclDebug ("Starting timer....");*/
1831 /* first time called, set up all the structs */
1833 sigemptyset (&nullsigmask
);
1835 act1
.sa_handler
= x_event
;
1836 act1
.sa_mask
= nullsigmask
;
1839 act2
.sa_handler
= SIG_IGN
;
1840 act2
.sa_mask
= nullsigmask
;
1843 it_on
.it_interval
.tv_sec
= 0;
1844 it_on
.it_interval
.tv_usec
= 250000; /* .25 sec */
1845 it_on
.it_value
.tv_sec
= 0;
1846 it_on
.it_value
.tv_usec
= 250000;
1848 it_off
.it_interval
.tv_sec
= 0;
1849 it_off
.it_interval
.tv_usec
= 0;
1850 it_off
.it_value
.tv_sec
= 0;
1851 it_off
.it_value
.tv_usec
= 0;
1854 if (!gdbtk_timer_going
)
1856 sigaction (SIGALRM
, &act1
, NULL
);
1857 setitimer (ITIMER_REAL
, &it_on
, NULL
);
1858 gdbtk_timer_going
= 1;
1865 if (gdbtk_timer_going
)
1867 gdbtk_timer_going
= 0;
1868 /*TclDebug ("Stopping timer.");*/
1869 setitimer (ITIMER_REAL
, &it_off
, NULL
);
1870 sigaction (SIGALRM
, &act2
, NULL
);
1874 /* This hook function is called whenever we want to wait for the
1878 gdbtk_wait (pid
, ourstatus
)
1880 struct target_waitstatus
*ourstatus
;
1882 gdbtk_start_timer ();
1883 pid
= target_wait (pid
, ourstatus
);
1884 gdbtk_stop_timer ();
1888 /* This is called from execute_command, and provides a wrapper around
1889 various command routines in a place where both protocol messages and
1890 user input both flow through. Mostly this is used for indicating whether
1891 the target process is running or not.
1895 gdbtk_call_command (cmdblk
, arg
, from_tty
)
1896 struct cmd_list_element
*cmdblk
;
1901 if (cmdblk
->class == class_run
|| cmdblk
->class == class_trace
)
1905 Tcl_Eval (interp
, "gdbtk_tcl_busy");
1906 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1909 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1912 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1915 /* This function is called instead of gdb's internal command loop. This is the
1916 last chance to do anything before entering the main Tk event loop. */
1921 extern GDB_FILE
*instream
;
1923 /* We no longer want to use stdin as the command input stream */
1926 if (Tcl_Eval (interp
, "gdbtk_tcl_preloop") != TCL_OK
)
1930 /* Force errorInfo to be set up propertly. */
1931 Tcl_AddErrorInfo (interp
, "");
1933 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
1935 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
1937 fputs_unfiltered (msg
, gdb_stderr
);
1948 /* gdbtk_init installs this function as a final cleanup. */
1951 gdbtk_cleanup (dummy
)
1955 struct ide_event_handle
*h
= (struct ide_event_handle
*) dummy
;
1957 ide_interface_deregister_all (h
);
1962 /* Initialize gdbtk. */
1965 gdbtk_init ( argv0
)
1968 struct cleanup
*old_chain
;
1969 char *lib
, *gdbtk_lib
, *gdbtk_lib_tmp
, *gdbtk_file
;
1972 struct sigaction action
;
1973 static sigset_t nullsigmask
= {0};
1976 /* start-sanitize-ide */
1977 struct ide_event_handle
*h
;
1980 /* end-sanitize-ide */
1983 /* If there is no DISPLAY environment variable, Tk_Init below will fail,
1984 causing gdb to abort. If instead we simply return here, gdb will
1985 gracefully degrade to using the command line interface. */
1988 if (getenv ("DISPLAY") == NULL
)
1992 old_chain
= make_cleanup (cleanup_init
, 0);
1994 /* First init tcl and tk. */
1995 Tcl_FindExecutable (argv0
);
1996 interp
= Tcl_CreateInterp ();
1998 #ifdef TCL_MEM_DEBUG
1999 Tcl_InitMemory (interp
);
2003 error ("Tcl_CreateInterp failed");
2005 if (Tcl_Init(interp
) != TCL_OK
)
2006 error ("Tcl_Init failed: %s", interp
->result
);
2009 /* For the IDE we register the cleanup later, after we've
2010 initialized events. */
2011 make_final_cleanup (gdbtk_cleanup
, NULL
);
2014 /* Initialize the Paths variable. */
2015 if (ide_initialize_paths (interp
, "gdbtcl") != TCL_OK
)
2016 error ("ide_initialize_paths failed: %s", interp
->result
);
2019 /* start-sanitize-ide */
2020 /* Find the directory where we expect to find idemanager. We ignore
2021 errors since it doesn't really matter if this fails. */
2022 libexecdir
= Tcl_GetVar2 (interp
, "Paths", "libexecdir", TCL_GLOBAL_ONLY
);
2026 h
= ide_event_init_from_environment (&errmsg
, libexecdir
);
2027 make_final_cleanup (gdbtk_cleanup
, h
);
2030 Tcl_AppendResult (interp
, "can't initialize event system: ", errmsg
,
2032 fprintf(stderr
, "WARNING: ide_event_init_client failed: %s\n", interp
->result
);
2034 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
2038 if (ide_create_tclevent_command (interp
, h
) != TCL_OK
)
2039 error ("ide_create_tclevent_command failed: %s", interp
->result
);
2041 if (ide_create_edit_command (interp
, h
) != TCL_OK
)
2042 error ("ide_create_edit_command failed: %s", interp
->result
);
2044 if (ide_create_property_command (interp
, h
) != TCL_OK
)
2045 error ("ide_create_property_command failed: %s", interp
->result
);
2047 if (ide_create_build_command (interp
, h
) != TCL_OK
)
2048 error ("ide_create_build_command failed: %s", interp
->result
);
2050 if (ide_create_window_register_command (interp
, h
, "gdb-restore")
2052 error ("ide_create_window_register_command failed: %s",
2055 if (ide_create_window_command (interp
, h
) != TCL_OK
)
2056 error ("ide_create_window_command failed: %s", interp
->result
);
2058 if (ide_create_exit_command (interp
, h
) != TCL_OK
)
2059 error ("ide_create_exit_command failed: %s", interp
->result
);
2061 if (ide_create_help_command (interp
) != TCL_OK
)
2062 error ("ide_create_help_command failed: %s", interp
->result
);
2065 if (ide_initialize (interp, "gdb") != TCL_OK)
2066 error ("ide_initialize failed: %s", interp->result);
2069 Tcl_SetVar (interp
, "GDBTK_IDE", "1", 0);
2071 /* end-sanitize-ide */
2073 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
2076 /* We don't want to open the X connection until we've done all the
2077 IDE initialization. Otherwise, goofy looking unfinished windows
2078 pop up when ILU drops into the TCL event loop. */
2080 if (Tk_Init(interp
) != TCL_OK
)
2081 error ("Tk_Init failed: %s", interp
->result
);
2083 if (Itcl_Init(interp
) == TCL_ERROR
)
2084 error ("Itcl_Init failed: %s", interp
->result
);
2086 if (Tix_Init(interp
) != TCL_OK
)
2087 error ("Tix_Init failed: %s", interp
->result
);
2090 if (ide_create_messagebox_command (interp
) != TCL_OK
)
2091 error ("messagebox command initialization failed");
2092 /* On Windows, create a sizebox widget command */
2093 if (ide_create_sizebox_command (interp
) != TCL_OK
)
2094 error ("sizebox creation failed");
2095 if (ide_create_winprint_command (interp
) != TCL_OK
)
2096 error ("windows print code initialization failed");
2097 /* start-sanitize-ide */
2098 /* An interface to ShellExecute. */
2099 if (ide_create_shell_execute_command (interp
) != TCL_OK
)
2100 error ("shell execute command initialization failed");
2101 /* end-sanitize-ide */
2102 if (ide_create_win_grab_command (interp
) != TCL_OK
)
2103 error ("grab support command initialization failed");
2104 /* Path conversion functions. */
2105 if (ide_create_cygwin_path_command (interp
) != TCL_OK
)
2106 error ("cygwin path command initialization failed");
2109 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
2110 Tcl_CreateCommand (interp
, "gdb_immediate", call_wrapper
,
2111 gdb_immediate_command
, NULL
);
2112 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
2113 Tcl_CreateCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
2114 Tcl_CreateObjCommand (interp
, "gdb_listfiles", gdb_listfiles
, NULL
, NULL
);
2115 Tcl_CreateCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
2117 Tcl_CreateCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
2119 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
2120 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
2121 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
2122 gdb_fetch_registers
, NULL
);
2123 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
2124 gdb_changed_register_list
, NULL
);
2125 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
2126 gdb_disassemble
, NULL
);
2127 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
2128 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
2129 gdb_get_breakpoint_list
, NULL
);
2130 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
2131 gdb_get_breakpoint_info
, NULL
);
2132 Tcl_CreateCommand (interp
, "gdb_clear_file", call_wrapper
,
2133 gdb_clear_file
, NULL
);
2134 Tcl_CreateCommand (interp
, "gdb_confirm_quit", call_wrapper
,
2135 gdb_confirm_quit
, NULL
);
2136 Tcl_CreateCommand (interp
, "gdb_force_quit", call_wrapper
,
2137 gdb_force_quit
, NULL
);
2138 Tcl_CreateCommand (interp
, "gdb_target_has_execution",
2139 gdb_target_has_execution_command
,
2141 Tcl_CreateCommand (interp
, "gdb_is_tracing",
2144 Tcl_CreateObjCommand (interp
, "gdb_load_info", gdb_load_info
, NULL
, NULL
);
2145 Tcl_CreateObjCommand (interp
, "gdb_get_locals", gdb_get_vars_command
,
2146 (ClientData
) 0, NULL
);
2147 Tcl_CreateObjCommand (interp
, "gdb_get_args", gdb_get_vars_command
,
2148 (ClientData
) 1, NULL
);
2149 Tcl_CreateObjCommand (interp
, "gdb_get_function", gdb_get_function_command
,
2151 Tcl_CreateObjCommand (interp
, "gdb_get_line", gdb_get_line_command
,
2153 Tcl_CreateObjCommand (interp
, "gdb_get_file", gdb_get_file_command
,
2155 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
2156 gdb_tracepoint_exists_command
, NULL
, NULL
);
2157 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
2158 gdb_get_tracepoint_info
, NULL
, NULL
);
2159 Tcl_CreateObjCommand (interp
, "gdb_actions",
2160 gdb_actions_command
, NULL
, NULL
);
2161 Tcl_CreateObjCommand (interp
, "gdb_prompt",
2162 gdb_prompt_command
, NULL
, NULL
);
2163 Tcl_CreateObjCommand (interp
, "gdb_find_file",
2164 gdb_find_file_command
, NULL
, NULL
);
2165 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
2166 gdb_get_tracepoint_list
, NULL
, NULL
);
2167 Tcl_CreateCommand (interp
, "gdb_pc_reg", get_pc_register
, NULL
, NULL
);
2168 Tcl_CreateObjCommand (interp
, "gdb_loadfile", gdb_loadfile
, NULL
, NULL
);
2169 Tcl_CreateObjCommand (interp
, "gdb_set_bp", gdb_set_bp
, NULL
, NULL
);
2171 command_loop_hook
= tk_command_loop
;
2172 print_frame_info_listing_hook
= gdbtk_print_frame_info
;
2173 query_hook
= gdbtk_query
;
2174 warning_hook
= gdbtk_warning
;
2175 flush_hook
= gdbtk_flush
;
2176 create_breakpoint_hook
= gdbtk_create_breakpoint
;
2177 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
2178 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
2179 interactive_hook
= gdbtk_interactive
;
2180 target_wait_hook
= gdbtk_wait
;
2181 call_command_hook
= gdbtk_call_command
;
2182 readline_begin_hook
= gdbtk_readline_begin
;
2183 readline_hook
= gdbtk_readline
;
2184 readline_end_hook
= gdbtk_readline_end
;
2185 ui_load_progress_hook
= gdbtk_load_hash
;
2186 pre_add_symbol_hook
= gdbtk_pre_add_symbol
;
2187 post_add_symbol_hook
= gdbtk_post_add_symbol
;
2188 create_tracepoint_hook
= gdbtk_create_tracepoint
;
2189 delete_tracepoint_hook
= gdbtk_delete_tracepoint
;
2190 modify_tracepoint_hook
= gdbtk_modify_tracepoint
;
2191 pc_changed_hook
= pc_changed
;
2193 add_com ("tk", class_obscure
, tk_command
,
2194 "Send a command directly into tk.");
2196 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
2199 /* find the gdb tcl library and source main.tcl */
2201 gdbtk_lib
= getenv ("GDBTK_LIBRARY");
2203 if (access ("gdbtcl/main.tcl", R_OK
) == 0)
2204 gdbtk_lib
= "gdbtcl";
2206 gdbtk_lib
= GDBTK_LIBRARY
;
2208 gdbtk_lib_tmp
= xstrdup (gdbtk_lib
);
2211 /* see if GDBTK_LIBRARY is a path list */
2212 lib
= strtok (gdbtk_lib_tmp
, GDBTK_PATH_SEP
);
2215 if (Tcl_VarEval (interp
, "lappend auto_path ", lib
, NULL
) != TCL_OK
)
2217 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2222 gdbtk_file
= concat (lib
, "/main.tcl", (char *) NULL
);
2223 if (access (gdbtk_file
, R_OK
) == 0)
2226 Tcl_SetVar (interp
, "GDBTK_LIBRARY", lib
, 0);
2230 while ((lib
= strtok (NULL
, ":")) != NULL
);
2232 free (gdbtk_lib_tmp
);
2236 /* Try finding it with the auto path. */
2238 static const char script
[] ="\
2239 proc gdbtk_find_main {} {\n\
2240 global auto_path GDBTK_LIBRARY\n\
2241 foreach dir $auto_path {\n\
2242 set f [file join $dir main.tcl]\n\
2243 if {[file exists $f]} then {\n\
2244 set GDBTK_LIBRARY $dir\n\
2252 if (Tcl_GlobalEval (interp
, (char *) script
) != TCL_OK
)
2254 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2258 if (interp
->result
[0] != '\0')
2260 gdbtk_file
= xstrdup (interp
->result
);
2267 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2268 if (getenv("GDBTK_LIBRARY"))
2270 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
2271 fprintf_unfiltered (stderr
,
2272 "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
2276 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY
);
2277 fprintf_unfiltered (stderr
, "You might want to set GDBTK_LIBRARY\n");
2282 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
2283 prior to this point go to stdout/stderr. */
2285 fputs_unfiltered_hook
= gdbtk_fputs
;
2287 if (Tcl_EvalFile (interp
, gdbtk_file
) != TCL_OK
)
2291 /* Force errorInfo to be set up propertly. */
2292 Tcl_AddErrorInfo (interp
, "");
2294 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
2296 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2299 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
2301 fputs_unfiltered (msg
, gdb_stderr
);
2308 /* start-sanitize-ide */
2309 /* Don't do this until we have initialized. Otherwise, we may get a
2310 run command before we are ready for one. */
2311 if (ide_run_server_init (interp
, h
) != TCL_OK
)
2312 error ("ide_run_server_init failed: %s", interp
->result
);
2313 /* end-sanitize-ide */
2318 discard_cleanups (old_chain
);
2322 gdb_target_has_execution_command (clientData
, interp
, argc
, argv
)
2323 ClientData clientData
;
2330 if (target_has_execution
&& inferior_pid
!= 0)
2333 Tcl_SetIntObj (Tcl_GetObjResult (interp
), result
);
2338 gdb_trace_status (clientData
, interp
, argc
, argv
)
2339 ClientData clientData
;
2346 if (trace_running_p
)
2349 Tcl_SetIntObj (Tcl_GetObjResult (interp
), result
);
2353 /* gdb_load_info - returns information about the file about to be downloaded */
2356 gdb_load_info (clientData
, interp
, objc
, objv
)
2357 ClientData clientData
;
2360 Tcl_Obj
*CONST objv
[];
2363 struct cleanup
*old_cleanups
;
2369 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
2371 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
2372 if (loadfile_bfd
== NULL
)
2374 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Open failed", -1));
2377 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
2379 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
2381 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Bad Object File", -1));
2385 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
2387 if (s
->flags
& SEC_LOAD
)
2389 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
2392 ob
[0] = Tcl_NewStringObj((char *)bfd_get_section_name(loadfile_bfd
, s
), -1);
2393 ob
[1] = Tcl_NewLongObj ((long)size
);
2394 res
[i
++] = Tcl_NewListObj (2, ob
);
2399 Tcl_SetObjResult (interp
, Tcl_NewListObj (i
, res
));
2400 do_cleanups (old_cleanups
);
2406 gdbtk_load_hash (section
, num
)
2411 sprintf (buf
, "download_hash %s %ld", section
, num
);
2412 Tcl_Eval (interp
, buf
);
2413 return atoi (interp
->result
);
2416 /* gdb_get_vars_command -
2418 * Implements the "gdb_get_locals" and "gdb_get_args" tcl commands. This
2419 * function sets the Tcl interpreter's result to a list of variable names
2420 * depending on clientData. If clientData is one, the result is a list of
2421 * arguments; zero returns a list of locals -- all relative to the block
2422 * specified as an argument to the command. Valid commands include
2423 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
2427 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
2428 ClientData clientData
;
2431 Tcl_Obj
*CONST objv
[];
2434 struct symtabs_and_lines sals
;
2436 struct block
*block
;
2437 char **canonical
, *args
;
2438 int i
, nsyms
, arguments
;
2442 Tcl_AppendResult (interp
,
2443 "wrong # of args: should be \"",
2444 Tcl_GetStringFromObj (objv
[0], NULL
),
2445 " function:line|function|line|*addr\"");
2449 arguments
= (int) clientData
;
2450 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2451 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2452 if (sals
.nelts
== 0)
2454 Tcl_AppendResult (interp
,
2455 "error decoding line", NULL
);
2459 /* Initialize a list that will hold the results */
2460 result
= Tcl_NewListObj (0, NULL
);
2462 /* Resolve all line numbers to PC's */
2463 for (i
= 0; i
< sals
.nelts
; i
++)
2464 resolve_sal_pc (&sals
.sals
[i
]);
2466 block
= block_for_pc (sals
.sals
[0].pc
);
2469 nsyms
= BLOCK_NSYMS (block
);
2470 for (i
= 0; i
< nsyms
; i
++)
2472 sym
= BLOCK_SYM (block
, i
);
2473 switch (SYMBOL_CLASS (sym
)) {
2475 case LOC_UNDEF
: /* catches errors */
2476 case LOC_CONST
: /* constant */
2477 case LOC_STATIC
: /* static */
2478 case LOC_REGISTER
: /* register */
2479 case LOC_TYPEDEF
: /* local typedef */
2480 case LOC_LABEL
: /* local label */
2481 case LOC_BLOCK
: /* local function */
2482 case LOC_CONST_BYTES
: /* loc. byte seq. */
2483 case LOC_UNRESOLVED
: /* unresolved static */
2484 case LOC_OPTIMIZED_OUT
: /* optimized out */
2486 case LOC_ARG
: /* argument */
2487 case LOC_REF_ARG
: /* reference arg */
2488 case LOC_REGPARM
: /* register arg */
2489 case LOC_REGPARM_ADDR
: /* indirect register arg */
2490 case LOC_LOCAL_ARG
: /* stack arg */
2491 case LOC_BASEREG_ARG
: /* basereg arg */
2493 Tcl_ListObjAppendElement (interp
, result
,
2494 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2496 case LOC_LOCAL
: /* stack local */
2497 case LOC_BASEREG
: /* basereg local */
2499 Tcl_ListObjAppendElement (interp
, result
,
2500 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2504 if (BLOCK_FUNCTION (block
))
2507 block
= BLOCK_SUPERBLOCK (block
);
2510 Tcl_SetObjResult (interp
, result
);
2515 gdb_get_line_command (clientData
, interp
, objc
, objv
)
2516 ClientData clientData
;
2519 Tcl_Obj
*CONST objv
[];
2522 struct symtabs_and_lines sals
;
2523 char *args
, **canonical
;
2527 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2528 Tcl_GetStringFromObj (objv
[0], NULL
),
2533 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2534 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2535 if (sals
.nelts
== 1)
2537 Tcl_SetObjResult (interp
, Tcl_NewIntObj (sals
.sals
[0].line
));
2541 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2546 gdb_get_file_command (clientData
, interp
, objc
, objv
)
2547 ClientData clientData
;
2550 Tcl_Obj
*CONST objv
[];
2553 struct symtabs_and_lines sals
;
2554 char *args
, **canonical
;
2558 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2559 Tcl_GetStringFromObj (objv
[0], NULL
),
2564 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2565 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2566 if (sals
.nelts
== 1)
2568 Tcl_SetResult (interp
, sals
.sals
[0].symtab
->filename
, TCL_VOLATILE
);
2572 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2577 gdb_get_function_command (clientData
, interp
, objc
, objv
)
2578 ClientData clientData
;
2581 Tcl_Obj
*CONST objv
[];
2585 struct symtabs_and_lines sals
;
2586 char *args
, **canonical
;
2590 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2591 Tcl_GetStringFromObj (objv
[0], NULL
),
2596 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2597 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2598 if (sals
.nelts
== 1)
2600 resolve_sal_pc (&sals
.sals
[0]);
2601 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
2602 if (function
!= NULL
)
2604 Tcl_SetResult (interp
, function
, TCL_VOLATILE
);
2609 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2614 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
2615 ClientData clientData
;
2618 Tcl_Obj
*CONST objv
[];
2620 struct symtab_and_line sal
;
2622 struct tracepoint
*tp
;
2623 struct action_line
*al
;
2624 Tcl_Obj
*list
, *action_list
;
2625 char *filename
, *funcname
;
2629 error ("wrong # args");
2631 Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
);
2633 ALL_TRACEPOINTS (tp
)
2634 if (tp
->number
== tpnum
)
2638 error ("Tracepoint #%d does not exist", tpnum
);
2640 list
= Tcl_NewListObj (0, NULL
);
2641 sal
= find_pc_line (tp
->address
, 0);
2642 filename
= symtab_to_filename (sal
.symtab
);
2643 if (filename
== NULL
)
2645 Tcl_ListObjAppendElement (interp
, list
,
2646 Tcl_NewStringObj (filename
, -1));
2647 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
2648 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (funcname
, -1));
2649 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (sal
.line
));
2650 sprintf (tmp
, "0x%lx", tp
->address
);
2651 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (tmp
, -1));
2652 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->enabled
));
2653 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->pass_count
));
2654 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->step_count
));
2655 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->thread
));
2656 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->hit_count
));
2658 /* Append a list of actions */
2659 action_list
= Tcl_NewListObj (0, NULL
);
2660 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
2662 Tcl_ListObjAppendElement (interp
, action_list
,
2663 Tcl_NewStringObj (al
->action
, -1));
2665 Tcl_ListObjAppendElement (interp
, list
, action_list
);
2667 Tcl_SetObjResult (interp
, list
);
2672 /* TclDebug (const char *fmt, ...) works just like printf() but */
2673 /* sends the output to the GDB TK debug window. */
2674 /* Not for normal use; just a convenient tool for debugging */
2676 #ifdef ANSI_PROTOTYPES
2677 TclDebug (const char *fmt
, ...)
2684 char buf
[512], *v
[2], *merge
;
2686 #ifdef ANSI_PROTOTYPES
2687 va_start (args
, fmt
);
2691 fmt
= va_arg (args
, char *);
2697 vsprintf (buf
, fmt
, args
);
2700 merge
= Tcl_Merge (2, v
);
2701 Tcl_Eval (interp
, merge
);
2706 /* Find the full pathname to a file, searching the symbol tables */
2709 gdb_find_file_command (clientData
, interp
, objc
, objv
)
2710 ClientData clientData
;
2713 Tcl_Obj
*CONST objv
[];
2715 char *filename
= NULL
;
2720 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
2724 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
2726 filename
= st
->fullname
;
2728 if (filename
== NULL
)
2729 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("", 0));
2731 Tcl_SetObjResult (interp
, Tcl_NewStringObj (filename
, -1));
2737 gdbtk_create_tracepoint (tp
)
2738 struct tracepoint
*tp
;
2740 tracepoint_notify (tp
, "create");
2744 gdbtk_delete_tracepoint (tp
)
2745 struct tracepoint
*tp
;
2747 tracepoint_notify (tp
, "delete");
2751 gdbtk_modify_tracepoint (tp
)
2752 struct tracepoint
*tp
;
2754 tracepoint_notify (tp
, "modify");
2758 tracepoint_notify(tp
, action
)
2759 struct tracepoint
*tp
;
2764 struct symtab_and_line sal
;
2767 /* We ensure that ACTION contains no special Tcl characters, so we
2769 sal
= find_pc_line (tp
->address
, 0);
2771 filename
= symtab_to_filename (sal
.symtab
);
2772 if (filename
== NULL
)
2774 sprintf (buf
, "gdbtk_tcl_tracepoint %s %d 0x%lx %d {%s}", action
, tp
->number
,
2775 (long)tp
->address
, sal
.line
, filename
, tp
->pass_count
);
2777 v
= Tcl_Eval (interp
, buf
);
2781 gdbtk_fputs (interp
->result
, gdb_stdout
);
2782 gdbtk_fputs ("\n", gdb_stdout
);
2786 /* returns -1 if not found, tracepoint # if found */
2788 tracepoint_exists (char * args
)
2790 struct tracepoint
*tp
;
2792 struct symtabs_and_lines sals
;
2796 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2797 if (sals
.nelts
== 1)
2799 resolve_sal_pc (&sals
.sals
[0]);
2800 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
2801 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
2804 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
2805 strcat (file
, sals
.sals
[0].symtab
->filename
);
2807 ALL_TRACEPOINTS (tp
)
2809 if (tp
->address
== sals
.sals
[0].pc
)
2810 result
= tp
->number
;
2812 /* Why is this here? This messes up assembly traces */
2813 else if (tp
->source_file
!= NULL
2814 && strcmp (tp
->source_file
, file
) == 0
2815 && sals
.sals
[0].line
== tp
->line_number
)
2816 result
= tp
->number
;
2827 gdb_actions_command (clientData
, interp
, objc
, objv
)
2828 ClientData clientData
;
2831 Tcl_Obj
*CONST objv
[];
2833 struct tracepoint
*tp
;
2835 int nactions
, i
, len
;
2836 char *number
, *args
, *action
;
2838 struct action_line
*next
= NULL
, *temp
;
2842 Tcl_AppendResult (interp
, "wrong # args: should be: \"",
2843 Tcl_GetStringFromObj (objv
[0], NULL
),
2844 " number actions\"");
2848 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
2849 tp
= get_tracepoint_by_number (&args
);
2852 Tcl_AppendResult (interp
, "Tracepoint \"", number
, "\" does not exist");
2856 /* Free any existing actions */
2857 if (tp
->actions
!= NULL
)
2862 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
2863 for (i
= 0; i
< nactions
; i
++)
2865 temp
= xmalloc (sizeof (struct action_line
));
2867 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
2868 temp
->action
= savestring (action
, len
);
2869 if (sscanf (temp
->action
, "while-stepping %d", &step_count
) !=0)
2870 tp
->step_count
= step_count
;
2887 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
2888 ClientData clientData
;
2891 Tcl_Obj
*CONST objv
[];
2897 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2898 Tcl_GetStringFromObj (objv
[0], NULL
),
2899 " function:line|function|line|*addr\"");
2903 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2905 Tcl_SetObjResult (interp
, Tcl_NewIntObj (tracepoint_exists (args
)));
2909 /* Return the prompt to the interpreter */
2911 gdb_prompt_command (clientData
, interp
, objc
, objv
)
2912 ClientData clientData
;
2915 Tcl_Obj
*CONST objv
[];
2917 Tcl_SetResult (interp
, get_prompt (), TCL_VOLATILE
);
2921 /* return a list of all tracepoint numbers in interpreter */
2923 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
2924 ClientData clientData
;
2927 Tcl_Obj
*CONST objv
[];
2930 struct tracepoint
*tp
;
2932 list
= Tcl_NewListObj (0, NULL
);
2934 ALL_TRACEPOINTS (tp
)
2935 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->number
));
2937 Tcl_SetObjResult (interp
, list
);
2942 /* This hook is called whenever we are ready to load a symbol file so that
2943 the UI can notify the user... */
2945 gdbtk_pre_add_symbol (name
)
2950 v
[0] = "gdbtk_tcl_pre_add_symbol";
2952 merge
= Tcl_Merge (2, v
);
2953 Tcl_Eval (interp
, merge
);
2957 /* This hook is called whenever we finish loading a symbol file. */
2959 gdbtk_post_add_symbol ()
2961 Tcl_Eval (interp
, "gdbtk_tcl_post_add_symbol");
2967 gdbtk_print_frame_info (s
, line
, stopline
, noerror
)
2973 current_source_symtab
= s
;
2974 current_source_line
= line
;
2978 /* The lookup_symtab() in symtab.c doesn't work correctly */
2979 /* It will not work will full pathnames and if multiple */
2980 /* source files have the same basename, it will return */
2981 /* the first one instead of the correct one. This version */
2982 /* also always makes sure symtab->fullname is set. */
2984 static struct symtab
*
2985 full_lookup_symtab(file
)
2989 struct objfile
*objfile
;
2990 char *bfile
, *fullname
;
2991 struct partial_symtab
*pt
;
2996 /* first try a direct lookup */
2997 st
= lookup_symtab (file
);
3001 symtab_to_filename(st
);
3005 /* if the direct approach failed, try */
3006 /* looking up the basename and checking */
3007 /* all matches with the fullname */
3008 bfile
= basename (file
);
3009 ALL_SYMTABS (objfile
, st
)
3011 if (!strcmp (bfile
, basename(st
->filename
)))
3014 fullname
= symtab_to_filename (st
);
3016 fullname
= st
->fullname
;
3018 if (!strcmp (file
, fullname
))
3023 /* still no luck? look at psymtabs */
3024 ALL_PSYMTABS (objfile
, pt
)
3026 if (!strcmp (bfile
, basename(pt
->filename
)))
3028 st
= PSYMTAB_TO_SYMTAB (pt
);
3031 fullname
= symtab_to_filename (st
);
3032 if (!strcmp (file
, fullname
))
3041 perror_with_name_wrapper (args
)
3044 perror_with_name (args
);
3048 /* gdb_loadfile loads a c source file into a text widget. */
3050 /* LTABLE_SIZE is the number of bytes to allocate for the */
3051 /* line table. Its size limits the maximum number of lines */
3052 /* in a file to 8 * LTABLE_SIZE. This memory is freed after */
3053 /* the file is loaded, so it is OK to make this very large. */
3054 /* Additional memory will be allocated if needed. */
3055 #define LTABLE_SIZE 20000
3058 gdb_loadfile (clientData
, interp
, objc
, objv
)
3059 ClientData clientData
;
3062 Tcl_Obj
*CONST objv
[];
3064 char *file
, *widget
, *line
, *buf
, msg
[128];
3065 int linenumbers
, ln
, anum
, lnum
, ltable_size
;
3066 Tcl_Obj
*a
[2], *b
[2], *cmd
;
3069 struct symtab
*symtab
;
3070 struct linetable_entry
*le
;
3077 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
3081 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
3082 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
3083 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
3085 if ((fp
= fopen ( file
, "r" )) == NULL
)
3088 symtab
= full_lookup_symtab (file
);
3091 sprintf(msg
, "File not found");
3092 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3097 if (stat (file
, &st
) < 0)
3099 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
3104 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
3105 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
3107 mtime
= bfd_get_mtime(exec_bfd
);
3109 if (mtime
&& mtime
< st
.st_mtime
)
3110 gdbtk_ignorable_warning("Source file is more recent than executable.\n", (va_list)0);
3113 /* Source linenumbers don't appear to be in order, and a sort is */
3114 /* too slow so the fastest solution is just to allocate a huge */
3115 /* array and set the array entry for each linenumber */
3117 ltable_size
= LTABLE_SIZE
;
3118 ltable
= (char *)malloc (LTABLE_SIZE
);
3121 sprintf(msg
, "Out of memory.");
3122 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3127 memset (ltable
, 0, LTABLE_SIZE
);
3129 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
3131 le
= symtab
->linetable
->item
;
3132 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
3134 lnum
= le
->line
>> 3;
3135 if (lnum
>= ltable_size
)
3138 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
3139 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
3141 if (new_ltable
== NULL
)
3143 sprintf(msg
, "Out of memory.");
3144 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3149 ltable
= new_ltable
;
3151 ltable
[lnum
] |= 1 << (le
->line
% 8);
3155 /* create an object with enough space, then grab its */
3156 /* buffer and sprintf directly into it. */
3157 a
[0] = Tcl_NewStringObj (ltable
, 1024);
3158 a
[1] = Tcl_NewListObj(0,NULL
);
3160 b
[0] = Tcl_NewStringObj (ltable
,1024);
3161 b
[1] = Tcl_NewStringObj ("source_tag", -1);
3162 Tcl_IncrRefCount (b
[0]);
3163 Tcl_IncrRefCount (b
[1]);
3164 line
= b
[0]->bytes
+ 1;
3165 strcpy(b
[0]->bytes
,"\t");
3168 while (fgets (line
, 980, fp
))
3172 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3174 sprintf (buf
,"%s insert end {-\t%d} break_tag", widget
, ln
);
3175 a
[0]->length
= strlen (buf
);
3179 sprintf (buf
,"%s insert end { \t%d} \"\"", widget
, ln
);
3180 a
[0]->length
= strlen (buf
);
3185 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3187 sprintf (buf
,"%s insert end {-\t} break_tag", widget
);
3188 a
[0]->length
= strlen (buf
);
3192 sprintf (buf
,"%s insert end { \t} \"\"", widget
);
3193 a
[0]->length
= strlen (buf
);
3196 b
[0]->length
= strlen(b
[0]->bytes
);
3197 Tcl_SetListObj(a
[1],2,b
);
3198 cmd
= Tcl_ConcatObj(2,a
);
3199 Tcl_EvalObj (interp
, cmd
);
3200 Tcl_DecrRefCount (cmd
);
3203 Tcl_DecrRefCount (b
[0]);
3204 Tcl_DecrRefCount (b
[0]);
3205 Tcl_DecrRefCount (b
[1]);
3206 Tcl_DecrRefCount (b
[1]);
3212 /* at some point make these static in breakpoint.c and move GUI code there */
3213 extern struct breakpoint
*set_raw_breakpoint (struct symtab_and_line sal
);
3214 extern void set_breakpoint_count (int);
3215 extern int breakpoint_count
;
3217 /* set a breakpoint by source file and line number */
3218 /* flags are as follows: */
3219 /* least significant 2 bits are disposition, rest is */
3220 /* type (normally 0).
3223 bp_breakpoint, Normal breakpoint
3224 bp_hardware_breakpoint, Hardware assisted breakpoint
3227 Disposition of breakpoint. Ie: what to do after hitting it.
3230 del_at_next_stop, Delete at next stop, whether hit or not
3232 donttouch Leave it alone
3237 gdb_set_bp (clientData
, interp
, objc
, objv
)
3238 ClientData clientData
;
3241 Tcl_Obj
*CONST objv
[];
3244 struct symtab_and_line sal
;
3245 int line
, flags
, ret
;
3246 struct breakpoint
*b
;
3248 Tcl_Obj
*a
[5], *cmd
;
3252 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
3256 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
3257 if (sal
.symtab
== NULL
)
3260 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
3263 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
3267 sal
.pc
= find_line_pc (sal
.symtab
, sal
.line
);
3271 sal
.section
= find_pc_overlay (sal
.pc
);
3272 b
= set_raw_breakpoint (sal
);
3273 set_breakpoint_count (breakpoint_count
+ 1);
3274 b
->number
= breakpoint_count
;
3275 b
->type
= flags
>> 2;
3276 b
->disposition
= flags
& 3;
3278 /* FIXME: this won't work for duplicate basenames! */
3279 sprintf (buf
, "%s:%d", basename(Tcl_GetStringFromObj( objv
[1], NULL
)), line
);
3280 b
->addr_string
= strsave (buf
);
3282 /* now send notification command back to GUI */
3283 sprintf (buf
, "0x%x", sal
.pc
);
3284 a
[0] = Tcl_NewStringObj ("gdbtk_tcl_breakpoint create", -1);
3285 a
[1] = Tcl_NewIntObj (b
->number
);
3286 a
[2] = Tcl_NewStringObj (buf
, -1);
3288 a
[4] = Tcl_NewListObj (1,&objv
[1]);
3289 cmd
= Tcl_ConcatObj(5,a
);
3290 ret
= Tcl_EvalObj (interp
, cmd
);
3291 Tcl_DecrRefCount (cmd
);
3295 /* Come here during initialize_all_files () */
3298 _initialize_gdbtk ()
3302 /* Tell the rest of the world that Gdbtk is now set up. */
3304 init_ui_hook
= gdbtk_init
;
3309 DWORD ft
= GetFileType (GetStdHandle (STD_INPUT_HANDLE
));
3310 void cygwin32_attach_handle_to_fd (char *, int, HANDLE
, int, int);
3314 case FILE_TYPE_DISK
:
3315 case FILE_TYPE_CHAR
:
3316 case FILE_TYPE_PIPE
:
3320 cygwin32_attach_handle_to_fd ("/dev/conin", 0,
3321 GetStdHandle (STD_INPUT_HANDLE
),
3323 cygwin32_attach_handle_to_fd ("/dev/conin", 1,
3324 GetStdHandle (STD_OUTPUT_HANDLE
),
3326 cygwin32_attach_handle_to_fd ("/dev/conin", 2,
3327 GetStdHandle (STD_ERROR_HANDLE
),