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"
45 /* start-sanitize-ide */
49 /* end-sanitize-ide */
52 #ifdef ANSI_PROTOTYPES
62 #include <sys/ioctl.h>
63 #include "gdb_string.h"
70 #include <sys/stropts.h>
80 #define GDBTK_PATH_SEP ";"
82 #define GDBTK_PATH_SEP ":"
85 /* Some versions (1.3.79, 1.3.81) of Linux don't support SIOCSPGRP the way
86 gdbtk wants to use it... */
91 static int No_Update
= 0;
92 static int load_in_progress
= 0;
93 static int in_fputs
= 0;
95 int gdbtk_load_hash
PARAMS ((char *, unsigned long));
96 int (*ui_load_progress_hook
) PARAMS ((char *, unsigned long));
97 void (*pre_add_symbol_hook
) PARAMS ((char *));
98 void (*post_add_symbol_hook
) PARAMS ((void));
100 /* This is a disgusting hack. Unfortunately, the UI will lock up if we
101 are doing something like blocking in a system call, waiting for serial I/O,
104 This hook should be used whenever we might block. This means adding appropriate
105 timeouts to code and what not to allow this hook to be called. */
106 void (*ui_loop_hook
) PARAMS ((int));
108 char * get_prompt
PARAMS ((void));
110 static void null_routine
PARAMS ((int));
111 static void gdbtk_flush
PARAMS ((FILE *));
112 static void gdbtk_fputs
PARAMS ((const char *, FILE *));
113 static int gdbtk_query
PARAMS ((const char *, va_list));
114 static char *gdbtk_readline
PARAMS ((char *));
115 static void gdbtk_init
PARAMS ((char *));
116 static void tk_command_loop
PARAMS ((void));
117 static void gdbtk_call_command
PARAMS ((struct cmd_list_element
*, char *, int));
118 static int gdbtk_wait
PARAMS ((int, struct target_waitstatus
*));
119 static void x_event
PARAMS ((int));
120 static void gdbtk_interactive
PARAMS ((void));
121 static void cleanup_init
PARAMS ((int));
122 static void tk_command
PARAMS ((char *, int));
123 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
124 static int compare_lines
PARAMS ((const PTR
, const PTR
));
125 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
126 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
127 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
128 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
129 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
130 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
131 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
132 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
133 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
134 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
135 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
136 static void gdbtk_readline_end
PARAMS ((void));
137 static void pc_changed
PARAMS ((void));
138 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
139 static void register_changed_p
PARAMS ((int, void *));
140 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
141 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
142 static void breakpoint_notify
PARAMS ((struct breakpoint
*, const char *));
143 static void gdbtk_create_breakpoint
PARAMS ((struct breakpoint
*));
144 static void gdbtk_delete_breakpoint
PARAMS ((struct breakpoint
*));
145 static void gdbtk_modify_breakpoint
PARAMS ((struct breakpoint
*));
146 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
147 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
148 static int map_arg_registers
PARAMS ((int, char *[], void (*) (int, void *), void *));
149 static void get_register_name
PARAMS ((int, void *));
150 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
151 static void get_register
PARAMS ((int, void *));
152 static int gdb_trace_status
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
153 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
154 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
155 void TclDebug
PARAMS ((const char *fmt
, ...));
156 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
157 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
158 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
159 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
160 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
161 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
162 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
163 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
164 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
165 static char *find_file_in_dir
PARAMS ((char *));
166 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
167 static void gdbtk_create_tracepoint
PARAMS ((struct tracepoint
*));
168 static void gdbtk_delete_tracepoint
PARAMS ((struct tracepoint
*));
169 static void gdbtk_modify_tracepoint
PARAMS ((struct tracepoint
*));
170 static void tracepoint_notify
PARAMS ((struct tracepoint
*, const char *));
171 static void gdbtk_print_frame_info
PARAMS ((struct symtab
*, int, int, int));
172 void gdbtk_pre_add_symbol
PARAMS ((char *));
173 void gdbtk_post_add_symbol
PARAMS ((void));
174 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
175 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
176 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
177 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
178 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
180 static void gdbtk_annotate_starting
PARAMS ((void));
181 static void gdbtk_annotate_stopped
PARAMS ((void));
182 static void gdbtk_annotate_signalled
PARAMS ((void));
183 static void gdbtk_annotate_exited
PARAMS ((void));
186 /* Handle for TCL interpreter */
187 static Tcl_Interp
*interp
= NULL
;
190 static int x_fd
; /* X network socket */
195 /* On Windows we use timer interrupts when gdb might otherwise hang
196 for a long time. See the comment above gdbtk_start_timer. This
197 variable is true when timer interrupts are being used. */
199 static int gdbtk_timer_going
= 0;
201 static void gdbtk_start_timer
PARAMS ((void));
202 static void gdbtk_stop_timer
PARAMS ((void));
206 /* This variable is true when the inferior is running. Although it's
207 possible to disable most input from widgets and thus prevent
208 attempts to do anything while the inferior is running, any commands
209 that get through - even a simple memory read - are Very Bad, and
210 may cause GDB to crash or behave strangely. So, this variable
211 provides an extra layer of defense. */
213 static int running_now
;
215 /* This variable determines where memory used for disassembly is read from.
216 If > 0, then disassembly comes from the exec file rather than the
217 target (which might be at the other end of a slow serial link). If
218 == 0 then disassembly comes from target. If < 0 disassembly is
219 automatically switched to the target if it's an inferior process,
220 otherwise the exec file is used. */
222 static int disassemble_from_exec
= -1;
226 /* Supply malloc calls for tcl/tk. We do not want to do this on
227 Windows, because Tcl_Alloc is probably in a DLL which will not call
228 the mmalloc routines. */
234 return xmalloc (size
);
238 Tcl_Realloc (ptr
, size
)
242 return xrealloc (ptr
, size
);
252 #endif /* ! _WIN32 */
262 /* On Windows, if we hold a file open, other programs can't write to
263 it. In particular, we don't want to hold the executable open,
264 because it will mean that people have to get out of the debugging
265 session in order to remake their program. So we close it, although
266 this will cost us if and when we need to reopen it. */
276 bfd_cache_close (o
->obfd
);
279 if (exec_bfd
!= NULL
)
280 bfd_cache_close (exec_bfd
);
285 /* The following routines deal with stdout/stderr data, which is created by
286 {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the
287 lowest level of these routines and capture all output from the rest of GDB.
288 Normally they present their data to tcl via callbacks to the following tcl
289 routines: gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush. These
290 in turn call tk routines to update the display.
292 Under some circumstances, you may want to collect the output so that it can
293 be returned as the value of a tcl procedure. This can be done by
294 surrounding the output routines with calls to start_saving_output and
295 finish_saving_output. The saved data can then be retrieved with
296 get_saved_output (but this must be done before the call to
297 finish_saving_output). */
299 /* Dynamic string for output. */
301 static Tcl_DString
*result_ptr
;
303 /* Dynamic string for stderr. This is only used if result_ptr is
306 static Tcl_DString
*error_string_ptr
;
313 /* Force immediate screen update */
315 Tcl_VarEval (interp
, "gdbtk_tcl_flush", NULL
);
320 gdbtk_fputs (ptr
, stream
)
324 char *merge
[2], *command
;
328 Tcl_DStringAppend (result_ptr
, (char *) ptr
, -1);
329 else if (error_string_ptr
!= NULL
&& stream
== gdb_stderr
)
330 Tcl_DStringAppend (error_string_ptr
, (char *) ptr
, -1);
333 merge
[0] = "gdbtk_tcl_fputs";
334 merge
[1] = (char *)ptr
;
335 command
= Tcl_Merge (2, merge
);
336 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. */
1071 gdb_immediate_command (clientData
, interp
, argc
, argv
)
1072 ClientData clientData
;
1077 Tcl_DString
*save_ptr
= NULL
;
1080 error ("wrong # args");
1082 if (running_now
|| load_in_progress
)
1087 Tcl_DStringAppend (result_ptr
, "", -1);
1088 save_ptr
= result_ptr
;
1091 execute_command (argv
[1], 1);
1093 bpstat_do_actions (&stop_bpstat
);
1095 result_ptr
= save_ptr
;
1100 /* This implements the TCL command `gdb_cmd', which sends its argument into
1101 the GDB command scanner. */
1104 gdb_cmd (clientData
, interp
, argc
, argv
)
1105 ClientData clientData
;
1110 Tcl_DString
*save_ptr
= NULL
;
1113 error ("wrong # args");
1115 if (running_now
|| load_in_progress
)
1118 /* If there is a third argument, it'll mean that we do NOT want to run
1119 the idle and busy hooks when we call execute_command. */
1125 /* for the load instruction (and possibly others later) we
1126 set result_ptr to NULL so gdbtk_fputs() will not buffer
1127 all the data until the command is finished. */
1129 if (strncmp ("load ", argv
[1], 5) == 0
1130 || strncmp ("while ", argv
[1], 6) == 0)
1132 Tcl_DStringAppend (result_ptr
, "", -1);
1133 save_ptr
= result_ptr
;
1135 load_in_progress
= 1;
1137 /* On Windows, use timer interrupts so that the user can cancel
1138 the download. FIXME: We may have to do something on other
1141 gdbtk_start_timer ();
1145 execute_command (argv
[1], 1);
1148 if (load_in_progress
)
1149 gdbtk_stop_timer ();
1152 load_in_progress
= 0;
1153 bpstat_do_actions (&stop_bpstat
);
1156 result_ptr
= save_ptr
;
1161 /* Client of call_wrapper - this routine performs the actual call to
1162 the client function. */
1164 struct wrapped_call_args
1175 struct wrapped_call_args
*args
;
1177 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->argc
, args
->argv
);
1181 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
1182 handles cleanups, and calls to return_to_top_level (usually via error).
1183 This is necessary in order to prevent a longjmp out of the bowels of Tk,
1184 possibly leaving things in a bad state. Since this routine can be called
1185 recursively, it needs to save and restore the contents of the jmp_buf as
1189 call_wrapper (clientData
, interp
, argc
, argv
)
1190 ClientData clientData
;
1195 struct wrapped_call_args wrapped_args
;
1196 Tcl_DString result
, *old_result_ptr
;
1197 Tcl_DString error_string
, *old_error_string_ptr
;
1199 Tcl_DStringInit (&result
);
1200 old_result_ptr
= result_ptr
;
1201 result_ptr
= &result
;
1203 Tcl_DStringInit (&error_string
);
1204 old_error_string_ptr
= error_string_ptr
;
1205 error_string_ptr
= &error_string
;
1207 wrapped_args
.func
= (Tcl_CmdProc
*)clientData
;
1208 wrapped_args
.interp
= interp
;
1209 wrapped_args
.argc
= argc
;
1210 wrapped_args
.argv
= argv
;
1211 wrapped_args
.val
= 0;
1213 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
1215 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
1218 /* Make sure the timer interrupts are turned off. */
1219 if (gdbtk_timer_going
)
1220 gdbtk_stop_timer ();
1223 gdb_flush (gdb_stderr
); /* Flush error output */
1224 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
1226 /* In case of an error, we may need to force the GUI into idle
1227 mode because gdbtk_call_command may have bombed out while in
1228 the command routine. */
1231 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1234 /* do not suppress any errors -- a remote target could have errored */
1235 load_in_progress
= 0;
1237 if (Tcl_DStringLength (&error_string
) == 0)
1239 Tcl_DStringResult (interp
, &result
);
1240 Tcl_DStringFree (&error_string
);
1242 else if (Tcl_DStringLength (&result
) == 0)
1244 Tcl_DStringResult (interp
, &error_string
);
1245 Tcl_DStringFree (&result
);
1246 Tcl_DStringFree (&error_string
);
1250 Tcl_ResetResult (interp
);
1251 Tcl_AppendResult (interp
, Tcl_DStringValue (&result
),
1252 Tcl_DStringValue (&error_string
), (char *) NULL
);
1253 Tcl_DStringFree (&result
);
1254 Tcl_DStringFree (&error_string
);
1257 result_ptr
= old_result_ptr
;
1258 error_string_ptr
= old_error_string_ptr
;
1264 return wrapped_args
.val
;
1268 comp_files (file1
, file2
)
1269 const char *file1
[], *file2
[];
1271 return strcmp(*file1
,*file2
);
1275 gdb_listfiles (clientData
, interp
, objc
, objv
)
1276 ClientData clientData
;
1279 Tcl_Obj
*CONST objv
[];
1281 struct objfile
*objfile
;
1282 struct partial_symtab
*psymtab
;
1283 struct symtab
*symtab
;
1284 char *lastfile
, *pathname
, *files
[1000];
1285 int i
, numfiles
= 0, len
= 0;
1290 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1294 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1296 mylist
= Tcl_NewListObj (0, NULL
);
1298 ALL_PSYMTABS (objfile
, psymtab
)
1302 if (psymtab
->filename
)
1303 files
[numfiles
++] = basename(psymtab
->filename
);
1305 else if (!strcmp(psymtab
->filename
,basename(psymtab
->filename
))
1306 || !strncmp(pathname
,psymtab
->filename
,len
))
1307 if (psymtab
->filename
)
1308 files
[numfiles
++] = basename(psymtab
->filename
);
1311 ALL_SYMTABS (objfile
, symtab
)
1315 if (symtab
->filename
)
1316 files
[numfiles
++] = basename(symtab
->filename
);
1318 else if (!strcmp(symtab
->filename
,basename(symtab
->filename
))
1319 || !strncmp(pathname
,symtab
->filename
,len
))
1320 if (symtab
->filename
)
1321 files
[numfiles
++] = basename(symtab
->filename
);
1324 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1327 for (i
= 0; i
< numfiles
; i
++)
1329 if (strcmp(files
[i
],lastfile
))
1330 Tcl_ListObjAppendElement (interp
, mylist
, Tcl_NewStringObj(files
[i
], -1));
1331 lastfile
= files
[i
];
1333 Tcl_SetObjResult (interp
, mylist
);
1338 gdb_listfuncs (clientData
, interp
, argc
, argv
)
1339 ClientData clientData
;
1344 struct symtab
*symtab
;
1345 struct blockvector
*bv
;
1352 error ("wrong # args");
1354 symtab
= full_lookup_symtab (argv
[1]);
1356 error ("No such file");
1358 bv
= BLOCKVECTOR (symtab
);
1359 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1361 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1362 /* Skip the sort if this block is always sorted. */
1363 if (!BLOCK_SHOULD_SORT (b
))
1364 sort_block_syms (b
);
1365 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1367 sym
= BLOCK_SYM (b
, j
);
1368 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1371 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1374 sprintf (buf
,"{%s} 1", name
);
1377 sprintf (buf
,"{%s} 0", SYMBOL_NAME(sym
));
1378 Tcl_DStringAppendElement (result_ptr
, buf
);
1386 target_stop_wrapper (args
)
1394 gdb_stop (clientData
, interp
, argc
, argv
)
1395 ClientData clientData
;
1402 catch_errors (target_stop_wrapper
, NULL
, "",
1406 quit_flag
= 1; /* hope something sees this */
1411 /* Prepare to accept a new executable file. This is called when we
1412 want to clear away everything we know about the old file, without
1413 asking the user. The Tcl code will have already asked the user if
1414 necessary. After this is called, we should be able to run the
1415 `file' command without getting any questions. */
1418 gdb_clear_file (clientData
, interp
, argc
, argv
)
1419 ClientData clientData
;
1424 if (inferior_pid
!= 0 && target_has_execution
)
1427 target_detach (NULL
, 0);
1432 if (target_has_execution
)
1435 symbol_file_command (NULL
, 0);
1437 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
1438 clear it here. FIXME: This seems like an abstraction violation
1445 /* Ask the user to confirm an exit request. */
1448 gdb_confirm_quit (clientData
, interp
, argc
, argv
)
1449 ClientData clientData
;
1456 ret
= quit_confirm ();
1457 Tcl_DStringAppendElement (result_ptr
, ret
? "1" : "0");
1461 /* Quit without asking for confirmation. */
1464 gdb_force_quit (clientData
, interp
, argc
, argv
)
1465 ClientData clientData
;
1470 quit_force ((char *) NULL
, 1);
1474 /* This implements the TCL command `gdb_disassemble'. */
1477 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
1481 disassemble_info
*info
;
1483 extern struct target_ops exec_ops
;
1487 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
1498 /* We need a different sort of line table from the normal one cuz we can't
1499 depend upon implicit line-end pc's for lines. This is because of the
1500 reordering we are about to do. */
1502 struct my_line_entry
{
1509 compare_lines (mle1p
, mle2p
)
1513 struct my_line_entry
*mle1
, *mle2
;
1516 mle1
= (struct my_line_entry
*) mle1p
;
1517 mle2
= (struct my_line_entry
*) mle2p
;
1519 val
= mle1
->line
- mle2
->line
;
1524 return mle1
->start_pc
- mle2
->start_pc
;
1528 gdb_disassemble (clientData
, interp
, argc
, argv
)
1529 ClientData clientData
;
1534 CORE_ADDR pc
, low
, high
;
1535 int mixed_source_and_assembly
;
1536 static disassemble_info di
;
1537 static int di_initialized
;
1539 if (! di_initialized
)
1541 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
1542 (fprintf_ftype
) fprintf_unfiltered
);
1543 di
.flavour
= bfd_target_unknown_flavour
;
1544 di
.memory_error_func
= dis_asm_memory_error
;
1545 di
.print_address_func
= dis_asm_print_address
;
1549 di
.mach
= tm_print_insn_info
.mach
;
1550 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
1551 di
.endian
= BFD_ENDIAN_BIG
;
1553 di
.endian
= BFD_ENDIAN_LITTLE
;
1555 if (argc
!= 3 && argc
!= 4)
1556 error ("wrong # args");
1558 if (strcmp (argv
[1], "source") == 0)
1559 mixed_source_and_assembly
= 1;
1560 else if (strcmp (argv
[1], "nosource") == 0)
1561 mixed_source_and_assembly
= 0;
1563 error ("First arg must be 'source' or 'nosource'");
1565 low
= parse_and_eval_address (argv
[2]);
1569 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
1570 error ("No function contains specified address");
1573 high
= parse_and_eval_address (argv
[3]);
1575 /* If disassemble_from_exec == -1, then we use the following heuristic to
1576 determine whether or not to do disassembly from target memory or from the
1579 If we're debugging a local process, read target memory, instead of the
1580 exec file. This makes disassembly of functions in shared libs work
1583 Else, we're debugging a remote process, and should disassemble from the
1584 exec file for speed. However, this is no good if the target modifies its
1585 code (for relocation, or whatever).
1588 if (disassemble_from_exec
== -1)
1589 if (strcmp (target_shortname
, "child") == 0
1590 || strcmp (target_shortname
, "procfs") == 0
1591 || strcmp (target_shortname
, "vxprocess") == 0)
1592 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
1594 disassemble_from_exec
= 1; /* It's remote, read the exec file */
1596 if (disassemble_from_exec
)
1597 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
1599 di
.read_memory_func
= dis_asm_read_memory
;
1601 /* If just doing straight assembly, all we need to do is disassemble
1602 everything between low and high. If doing mixed source/assembly, we've
1603 got a totally different path to follow. */
1605 if (mixed_source_and_assembly
)
1606 { /* Come here for mixed source/assembly */
1607 /* The idea here is to present a source-O-centric view of a function to
1608 the user. This means that things are presented in source order, with
1609 (possibly) out of order assembly immediately following. */
1610 struct symtab
*symtab
;
1611 struct linetable_entry
*le
;
1614 struct my_line_entry
*mle
;
1615 struct symtab_and_line sal
;
1620 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
1625 /* First, convert the linetable to a bunch of my_line_entry's. */
1627 le
= symtab
->linetable
->item
;
1628 nlines
= symtab
->linetable
->nitems
;
1633 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
1637 /* Copy linetable entries for this function into our data structure, creating
1638 end_pc's and setting out_of_order as appropriate. */
1640 /* First, skip all the preceding functions. */
1642 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
1644 /* Now, copy all entries before the end of this function. */
1647 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
1649 if (le
[i
].line
== le
[i
+ 1].line
1650 && le
[i
].pc
== le
[i
+ 1].pc
)
1651 continue; /* Ignore duplicates */
1653 mle
[newlines
].line
= le
[i
].line
;
1654 if (le
[i
].line
> le
[i
+ 1].line
)
1656 mle
[newlines
].start_pc
= le
[i
].pc
;
1657 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
1661 /* If we're on the last line, and it's part of the function, then we need to
1662 get the end pc in a special way. */
1667 mle
[newlines
].line
= le
[i
].line
;
1668 mle
[newlines
].start_pc
= le
[i
].pc
;
1669 sal
= find_pc_line (le
[i
].pc
, 0);
1670 mle
[newlines
].end_pc
= sal
.end
;
1674 /* Now, sort mle by line #s (and, then by addresses within lines). */
1677 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
1679 /* Now, for each line entry, emit the specified lines (unless they have been
1680 emitted before), followed by the assembly code for that line. */
1682 next_line
= 0; /* Force out first line */
1683 for (i
= 0; i
< newlines
; i
++)
1685 /* Print out everything from next_line to the current line. */
1687 if (mle
[i
].line
>= next_line
)
1690 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
1692 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
1694 next_line
= mle
[i
].line
+ 1;
1697 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
1700 fputs_unfiltered (" ", gdb_stdout
);
1701 print_address (pc
, gdb_stdout
);
1702 fputs_unfiltered (":\t ", gdb_stdout
);
1703 pc
+= (*tm_print_insn
) (pc
, &di
);
1704 fputs_unfiltered ("\n", gdb_stdout
);
1711 for (pc
= low
; pc
< high
; )
1714 fputs_unfiltered (" ", gdb_stdout
);
1715 print_address (pc
, gdb_stdout
);
1716 fputs_unfiltered (":\t ", gdb_stdout
);
1717 pc
+= (*tm_print_insn
) (pc
, &di
);
1718 fputs_unfiltered ("\n", gdb_stdout
);
1722 gdb_flush (gdb_stdout
);
1728 tk_command (cmd
, from_tty
)
1734 struct cleanup
*old_chain
;
1736 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1738 error_no_arg ("tcl command to interpret");
1740 retval
= Tcl_Eval (interp
, cmd
);
1742 result
= strdup (interp
->result
);
1744 old_chain
= make_cleanup (free
, result
);
1746 if (retval
!= TCL_OK
)
1749 printf_unfiltered ("%s\n", result
);
1751 do_cleanups (old_chain
);
1755 cleanup_init (ignored
)
1759 Tcl_DeleteInterp (interp
);
1763 /* Come here during long calculations to check for GUI events. Usually invoked
1764 via the QUIT macro. */
1767 gdbtk_interactive ()
1769 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1772 /* Come here when there is activity on the X file descriptor. */
1778 static int in_x_event
= 0;
1779 static Tcl_Obj
*varname
= NULL
;
1781 if (in_x_event
|| in_fputs
)
1786 /* Process pending events */
1787 while (Tcl_DoOneEvent (TCL_DONT_WAIT
|TCL_ALL_EVENTS
) != 0)
1790 if (load_in_progress
)
1793 if (varname
== NULL
)
1795 Tcl_Obj
*varnamestrobj
= Tcl_NewStringObj("download_cancel_ok",-1);
1796 varname
= Tcl_ObjGetVar2(interp
,varnamestrobj
,NULL
,TCL_GLOBAL_ONLY
);
1798 if ((Tcl_GetIntFromObj(interp
,varname
,&val
) == TCL_OK
) && val
)
1814 /* For Cygwin32, we use a timer to periodically check for Windows
1815 messages. FIXME: It would be better to not poll, but to instead
1816 rewrite the target_wait routines to serve as input sources.
1817 Unfortunately, that will be a lot of work. */
1818 static sigset_t nullsigmask
;
1819 static struct sigaction act1
, act2
;
1820 static struct itimerval it_on
, it_off
;
1823 gdbtk_start_timer ()
1825 static int first
= 1;
1826 /*TclDebug ("Starting timer....");*/
1829 /* first time called, set up all the structs */
1831 sigemptyset (&nullsigmask
);
1833 act1
.sa_handler
= x_event
;
1834 act1
.sa_mask
= nullsigmask
;
1837 act2
.sa_handler
= SIG_IGN
;
1838 act2
.sa_mask
= nullsigmask
;
1841 it_on
.it_interval
.tv_sec
= 0;
1842 it_on
.it_interval
.tv_usec
= 500000; /* .5 sec */
1843 it_on
.it_value
.tv_sec
= 0;
1844 it_on
.it_value
.tv_usec
= 500000;
1846 it_off
.it_interval
.tv_sec
= 0;
1847 it_off
.it_interval
.tv_usec
= 0;
1848 it_off
.it_value
.tv_sec
= 0;
1849 it_off
.it_value
.tv_usec
= 0;
1851 sigaction (SIGALRM
, &act1
, NULL
);
1852 setitimer (ITIMER_REAL
, &it_on
, NULL
);
1853 gdbtk_timer_going
= 1;
1859 gdbtk_timer_going
= 0;
1860 /*TclDebug ("Stopping timer.");*/
1861 setitimer (ITIMER_REAL
, &it_off
, NULL
);
1862 sigaction (SIGALRM
, &act2
, NULL
);
1867 /* This hook function is called whenever we want to wait for the
1871 gdbtk_wait (pid
, ourstatus
)
1873 struct target_waitstatus
*ourstatus
;
1876 struct sigaction action
;
1877 static sigset_t nullsigmask
= {0};
1881 /* Needed for SunOS 4.1.x */
1882 #define SA_RESTART 0
1885 action
.sa_handler
= x_event
;
1886 action
.sa_mask
= nullsigmask
;
1887 action
.sa_flags
= SA_RESTART
;
1888 sigaction(SIGIO
, &action
, NULL
);
1891 pid
= target_wait (pid
, ourstatus
);
1894 action
.sa_handler
= SIG_IGN
;
1895 sigaction(SIGIO
, &action
, NULL
);
1901 /* This is called from execute_command, and provides a wrapper around
1902 various command routines in a place where both protocol messages and
1903 user input both flow through. Mostly this is used for indicating whether
1904 the target process is running or not.
1908 gdbtk_call_command (cmdblk
, arg
, from_tty
)
1909 struct cmd_list_element
*cmdblk
;
1914 if (cmdblk
->class == class_run
|| cmdblk
->class == class_trace
)
1918 Tcl_Eval (interp
, "gdbtk_tcl_busy");
1919 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1922 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1925 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1928 /* This function is called instead of gdb's internal command loop. This is the
1929 last chance to do anything before entering the main Tk event loop. */
1934 extern GDB_FILE
*instream
;
1936 /* We no longer want to use stdin as the command input stream */
1939 if (Tcl_Eval (interp
, "gdbtk_tcl_preloop") != TCL_OK
)
1943 /* Force errorInfo to be set up propertly. */
1944 Tcl_AddErrorInfo (interp
, "");
1946 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
1948 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
1950 fputs_unfiltered (msg
, gdb_stderr
);
1961 /* gdbtk_init installs this function as a final cleanup. */
1964 gdbtk_cleanup (dummy
)
1968 struct ide_event_handle
*h
= (struct ide_event_handle
*) dummy
;
1970 ide_interface_deregister_all (h
);
1975 /* Initialize gdbtk. */
1978 gdbtk_init ( argv0
)
1981 struct cleanup
*old_chain
;
1982 char *lib
, *gdbtk_lib
, *gdbtk_lib_tmp
, *gdbtk_file
;
1985 struct sigaction action
;
1986 static sigset_t nullsigmask
= {0};
1989 /* start-sanitize-ide */
1990 struct ide_event_handle
*h
;
1993 /* end-sanitize-ide */
1996 /* If there is no DISPLAY environment variable, Tk_Init below will fail,
1997 causing gdb to abort. If instead we simply return here, gdb will
1998 gracefully degrade to using the command line interface. */
2001 if (getenv ("DISPLAY") == NULL
)
2005 old_chain
= make_cleanup (cleanup_init
, 0);
2007 /* First init tcl and tk. */
2008 Tcl_FindExecutable (argv0
);
2009 interp
= Tcl_CreateInterp ();
2011 #ifdef TCL_MEM_DEBUG
2012 Tcl_InitMemory (interp
);
2016 error ("Tcl_CreateInterp failed");
2018 if (Tcl_Init(interp
) != TCL_OK
)
2019 error ("Tcl_Init failed: %s", interp
->result
);
2022 /* For the IDE we register the cleanup later, after we've
2023 initialized events. */
2024 make_final_cleanup (gdbtk_cleanup
, NULL
);
2027 /* Initialize the Paths variable. */
2028 if (ide_initialize_paths (interp
, "gdbtcl") != TCL_OK
)
2029 error ("ide_initialize_paths failed: %s", interp
->result
);
2032 /* start-sanitize-ide */
2033 /* Find the directory where we expect to find idemanager. We ignore
2034 errors since it doesn't really matter if this fails. */
2035 libexecdir
= Tcl_GetVar2 (interp
, "Paths", "libexecdir", TCL_GLOBAL_ONLY
);
2039 h
= ide_event_init_from_environment (&errmsg
, libexecdir
);
2040 make_final_cleanup (gdbtk_cleanup
, h
);
2043 Tcl_AppendResult (interp
, "can't initialize event system: ", errmsg
,
2045 fprintf(stderr
, "WARNING: ide_event_init_client failed: %s\n", interp
->result
);
2047 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
2051 if (ide_create_tclevent_command (interp
, h
) != TCL_OK
)
2052 error ("ide_create_tclevent_command failed: %s", interp
->result
);
2054 if (ide_create_edit_command (interp
, h
) != TCL_OK
)
2055 error ("ide_create_edit_command failed: %s", interp
->result
);
2057 if (ide_create_property_command (interp
, h
) != TCL_OK
)
2058 error ("ide_create_property_command failed: %s", interp
->result
);
2060 if (ide_create_build_command (interp
, h
) != TCL_OK
)
2061 error ("ide_create_build_command failed: %s", interp
->result
);
2063 if (ide_create_window_register_command (interp
, h
, "gdb-restore")
2065 error ("ide_create_window_register_command failed: %s",
2068 if (ide_create_window_command (interp
, h
) != TCL_OK
)
2069 error ("ide_create_window_command failed: %s", interp
->result
);
2071 if (ide_create_exit_command (interp
, h
) != TCL_OK
)
2072 error ("ide_create_exit_command failed: %s", interp
->result
);
2074 if (ide_create_help_command (interp
) != TCL_OK
)
2075 error ("ide_create_help_command failed: %s", interp
->result
);
2078 if (ide_initialize (interp, "gdb") != TCL_OK)
2079 error ("ide_initialize failed: %s", interp->result);
2082 Tcl_SetVar (interp
, "GDBTK_IDE", "1", 0);
2083 Tcl_SetVar (interp
, "IDE", "1", TCL_GLOBAL_ONLY
);
2085 /* end-sanitize-ide */
2087 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
2090 /* We don't want to open the X connection until we've done all the
2091 IDE initialization. Otherwise, goofy looking unfinished windows
2092 pop up when ILU drops into the TCL event loop. */
2094 if (Tk_Init(interp
) != TCL_OK
)
2095 error ("Tk_Init failed: %s", interp
->result
);
2097 if (Itcl_Init(interp
) == TCL_ERROR
)
2098 error ("Itcl_Init failed: %s", interp
->result
);
2100 if (Tix_Init(interp
) != TCL_OK
)
2101 error ("Tix_Init failed: %s", interp
->result
);
2104 if (ide_create_messagebox_command (interp
) != TCL_OK
)
2105 error ("messagebox command initialization failed");
2106 /* On Windows, create a sizebox widget command */
2107 if (ide_create_sizebox_command (interp
) != TCL_OK
)
2108 error ("sizebox creation failed");
2109 if (ide_create_winprint_command (interp
) != TCL_OK
)
2110 error ("windows print code initialization failed");
2111 /* start-sanitize-ide */
2112 /* An interface to ShellExecute. */
2113 if (ide_create_shell_execute_command (interp
) != TCL_OK
)
2114 error ("shell execute command initialization failed");
2115 /* end-sanitize-ide */
2116 if (ide_create_win_grab_command (interp
) != TCL_OK
)
2117 error ("grab support command initialization failed");
2118 /* Path conversion functions. */
2119 if (ide_create_cygwin_path_command (interp
) != TCL_OK
)
2120 error ("cygwin path command initialization failed");
2123 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
2124 Tcl_CreateCommand (interp
, "gdb_immediate", call_wrapper
,
2125 gdb_immediate_command
, NULL
);
2126 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
2127 Tcl_CreateCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
2128 Tcl_CreateObjCommand (interp
, "gdb_listfiles", gdb_listfiles
, NULL
, NULL
);
2129 Tcl_CreateCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
2131 Tcl_CreateCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
2133 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
2134 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
2135 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
2136 gdb_fetch_registers
, NULL
);
2137 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
2138 gdb_changed_register_list
, NULL
);
2139 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
2140 gdb_disassemble
, NULL
);
2141 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
2142 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
2143 gdb_get_breakpoint_list
, NULL
);
2144 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
2145 gdb_get_breakpoint_info
, NULL
);
2146 Tcl_CreateCommand (interp
, "gdb_clear_file", call_wrapper
,
2147 gdb_clear_file
, NULL
);
2148 Tcl_CreateCommand (interp
, "gdb_confirm_quit", call_wrapper
,
2149 gdb_confirm_quit
, NULL
);
2150 Tcl_CreateCommand (interp
, "gdb_force_quit", call_wrapper
,
2151 gdb_force_quit
, NULL
);
2152 Tcl_CreateCommand (interp
, "gdb_target_has_execution",
2153 gdb_target_has_execution_command
,
2155 Tcl_CreateCommand (interp
, "gdb_is_tracing",
2158 Tcl_CreateObjCommand (interp
, "gdb_load_info", gdb_load_info
, NULL
, NULL
);
2159 Tcl_CreateObjCommand (interp
, "gdb_get_locals", gdb_get_vars_command
,
2160 (ClientData
) 0, NULL
);
2161 Tcl_CreateObjCommand (interp
, "gdb_get_args", gdb_get_vars_command
,
2162 (ClientData
) 1, NULL
);
2163 Tcl_CreateObjCommand (interp
, "gdb_get_function", gdb_get_function_command
,
2165 Tcl_CreateObjCommand (interp
, "gdb_get_line", gdb_get_line_command
,
2167 Tcl_CreateObjCommand (interp
, "gdb_get_file", gdb_get_file_command
,
2169 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
2170 gdb_tracepoint_exists_command
, NULL
, NULL
);
2171 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
2172 gdb_get_tracepoint_info
, NULL
, NULL
);
2173 Tcl_CreateObjCommand (interp
, "gdb_actions",
2174 gdb_actions_command
, NULL
, NULL
);
2175 Tcl_CreateObjCommand (interp
, "gdb_prompt",
2176 gdb_prompt_command
, NULL
, NULL
);
2177 Tcl_CreateObjCommand (interp
, "gdb_find_file",
2178 gdb_find_file_command
, NULL
, NULL
);
2179 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
2180 gdb_get_tracepoint_list
, NULL
, NULL
);
2181 Tcl_CreateCommand (interp
, "gdb_pc_reg", get_pc_register
, NULL
, NULL
);
2182 Tcl_CreateObjCommand (interp
, "gdb_loadfile", gdb_loadfile
, NULL
, NULL
);
2183 Tcl_CreateObjCommand (interp
, "gdb_set_bp", gdb_set_bp
, NULL
, NULL
);
2185 command_loop_hook
= tk_command_loop
;
2186 print_frame_info_listing_hook
= gdbtk_print_frame_info
;
2187 query_hook
= gdbtk_query
;
2188 flush_hook
= gdbtk_flush
;
2189 create_breakpoint_hook
= gdbtk_create_breakpoint
;
2190 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
2191 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
2192 interactive_hook
= gdbtk_interactive
;
2193 target_wait_hook
= gdbtk_wait
;
2194 call_command_hook
= gdbtk_call_command
;
2195 readline_begin_hook
= gdbtk_readline_begin
;
2196 readline_hook
= gdbtk_readline
;
2197 readline_end_hook
= gdbtk_readline_end
;
2198 ui_load_progress_hook
= gdbtk_load_hash
;
2199 pre_add_symbol_hook
= gdbtk_pre_add_symbol
;
2200 post_add_symbol_hook
= gdbtk_post_add_symbol
;
2201 create_tracepoint_hook
= gdbtk_create_tracepoint
;
2202 delete_tracepoint_hook
= gdbtk_delete_tracepoint
;
2203 modify_tracepoint_hook
= gdbtk_modify_tracepoint
;
2204 pc_changed_hook
= pc_changed
;
2206 annotate_starting_hook
= gdbtk_annotate_starting
;
2207 annotate_stopped_hook
= gdbtk_annotate_stopped
;
2208 annotate_signalled_hook
= gdbtk_annotate_signalled
;
2209 annotate_exited_hook
= gdbtk_annotate_exited
;
2210 ui_loop_hook
= x_event
;
2213 /* Get the file descriptor for the X server */
2215 x_fd
= ConnectionNumber (Tk_Display (Tk_MainWindow (interp
)));
2217 /* Setup for I/O interrupts */
2219 action
.sa_mask
= nullsigmask
;
2220 action
.sa_flags
= 0;
2221 action
.sa_handler
= SIG_IGN
;
2222 sigaction(SIGIO
, &action
, NULL
);
2226 if (ioctl (x_fd
, FIOASYNC
, &i
))
2227 perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
2231 if (ioctl (x_fd
, SIOCSPGRP
, &i
))
2232 perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
2237 if (fcntl (x_fd
, F_SETOWN
, i
))
2238 perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
2239 #endif /* F_SETOWN */
2240 #endif /* !SIOCSPGRP */
2243 if (ioctl (x_fd
, I_SETSIG
, S_INPUT
|S_RDNORM
) < 0)
2244 perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
2247 #endif /* ifndef FIOASYNC */
2250 add_com ("tk", class_obscure
, tk_command
,
2251 "Send a command directly into tk.");
2253 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
2256 /* find the gdb tcl library and source main.tcl */
2258 gdbtk_lib
= getenv ("GDBTK_LIBRARY");
2260 if (access ("gdbtcl/main.tcl", R_OK
) == 0)
2261 gdbtk_lib
= "gdbtcl";
2263 gdbtk_lib
= GDBTK_LIBRARY
;
2265 gdbtk_lib_tmp
= xstrdup (gdbtk_lib
);
2268 /* see if GDBTK_LIBRARY is a path list */
2269 lib
= strtok (gdbtk_lib_tmp
, GDBTK_PATH_SEP
);
2272 if (Tcl_VarEval (interp
, "lappend auto_path ", lib
, NULL
) != TCL_OK
)
2274 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2279 gdbtk_file
= concat (lib
, "/main.tcl", (char *) NULL
);
2280 if (access (gdbtk_file
, R_OK
) == 0)
2283 Tcl_SetVar (interp
, "GDBTK_LIBRARY", lib
, 0);
2287 while ((lib
= strtok (NULL
, ":")) != NULL
);
2289 free (gdbtk_lib_tmp
);
2293 /* Try finding it with the auto path. */
2295 static const char script
[] ="\
2296 proc gdbtk_find_main {} {\n\
2297 global auto_path GDBTK_LIBRARY\n\
2298 foreach dir $auto_path {\n\
2299 set f [file join $dir main.tcl]\n\
2300 if {[file exists $f]} then {\n\
2301 set GDBTK_LIBRARY $dir\n\
2309 if (Tcl_GlobalEval (interp
, (char *) script
) != TCL_OK
)
2311 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2315 if (interp
->result
[0] != '\0')
2317 gdbtk_file
= xstrdup (interp
->result
);
2324 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2325 if (getenv("GDBTK_LIBRARY"))
2327 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
2328 fprintf_unfiltered (stderr
,
2329 "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
2333 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY
);
2334 fprintf_unfiltered (stderr
, "You might want to set GDBTK_LIBRARY\n");
2339 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
2340 prior to this point go to stdout/stderr. */
2342 fputs_unfiltered_hook
= gdbtk_fputs
;
2344 if (Tcl_EvalFile (interp
, gdbtk_file
) != TCL_OK
)
2348 /* Force errorInfo to be set up propertly. */
2349 Tcl_AddErrorInfo (interp
, "");
2351 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
2353 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2356 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
2358 fputs_unfiltered (msg
, gdb_stderr
);
2365 /* start-sanitize-ide */
2366 /* Don't do this until we have initialized. Otherwise, we may get a
2367 run command before we are ready for one. */
2368 if (ide_run_server_init (interp
, h
) != TCL_OK
)
2369 error ("ide_run_server_init failed: %s", interp
->result
);
2370 /* end-sanitize-ide */
2375 discard_cleanups (old_chain
);
2379 gdb_target_has_execution_command (clientData
, interp
, argc
, argv
)
2380 ClientData clientData
;
2387 if (target_has_execution
&& inferior_pid
!= 0)
2390 Tcl_SetIntObj (Tcl_GetObjResult (interp
), result
);
2395 gdb_trace_status (clientData
, interp
, argc
, argv
)
2396 ClientData clientData
;
2403 if (trace_running_p
)
2406 Tcl_SetIntObj (Tcl_GetObjResult (interp
), result
);
2410 /* gdb_load_info - returns information about the file about to be downloaded */
2413 gdb_load_info (clientData
, interp
, objc
, objv
)
2414 ClientData clientData
;
2417 Tcl_Obj
*CONST objv
[];
2420 struct cleanup
*old_cleanups
;
2426 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
2428 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
2429 if (loadfile_bfd
== NULL
)
2431 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Open failed", -1));
2434 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
2436 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
2438 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Bad Object File", -1));
2442 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
2444 if (s
->flags
& SEC_LOAD
)
2446 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
2449 ob
[0] = Tcl_NewStringObj((char *)bfd_get_section_name(loadfile_bfd
, s
), -1);
2450 ob
[1] = Tcl_NewLongObj ((long)size
);
2451 res
[i
++] = Tcl_NewListObj (2, ob
);
2456 Tcl_SetObjResult (interp
, Tcl_NewListObj (i
, res
));
2457 do_cleanups (old_cleanups
);
2463 gdbtk_load_hash (section
, num
)
2468 sprintf (buf
, "download_hash %s %ld", section
, num
);
2469 Tcl_Eval (interp
, buf
);
2470 return atoi (interp
->result
);
2473 /* gdb_get_vars_command -
2475 * Implements the "gdb_get_locals" and "gdb_get_args" tcl commands. This
2476 * function sets the Tcl interpreter's result to a list of variable names
2477 * depending on clientData. If clientData is one, the result is a list of
2478 * arguments; zero returns a list of locals -- all relative to the block
2479 * specified as an argument to the command. Valid commands include
2480 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
2484 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
2485 ClientData clientData
;
2488 Tcl_Obj
*CONST objv
[];
2491 struct symtabs_and_lines sals
;
2493 struct block
*block
;
2494 char **canonical
, *args
;
2495 int i
, nsyms
, arguments
;
2499 Tcl_AppendResult (interp
,
2500 "wrong # of args: should be \"",
2501 Tcl_GetStringFromObj (objv
[0], NULL
),
2502 " function:line|function|line|*addr\"");
2506 arguments
= (int) clientData
;
2507 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2508 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2509 if (sals
.nelts
== 0)
2511 Tcl_AppendResult (interp
,
2512 "error decoding line", NULL
);
2516 /* Initialize a list that will hold the results */
2517 result
= Tcl_NewListObj (0, NULL
);
2519 /* Resolve all line numbers to PC's */
2520 for (i
= 0; i
< sals
.nelts
; i
++)
2521 resolve_sal_pc (&sals
.sals
[i
]);
2523 block
= block_for_pc (sals
.sals
[0].pc
);
2526 nsyms
= BLOCK_NSYMS (block
);
2527 for (i
= 0; i
< nsyms
; i
++)
2529 sym
= BLOCK_SYM (block
, i
);
2530 switch (SYMBOL_CLASS (sym
)) {
2532 case LOC_UNDEF
: /* catches errors */
2533 case LOC_CONST
: /* constant */
2534 case LOC_STATIC
: /* static */
2535 case LOC_REGISTER
: /* register */
2536 case LOC_TYPEDEF
: /* local typedef */
2537 case LOC_LABEL
: /* local label */
2538 case LOC_BLOCK
: /* local function */
2539 case LOC_CONST_BYTES
: /* loc. byte seq. */
2540 case LOC_UNRESOLVED
: /* unresolved static */
2541 case LOC_OPTIMIZED_OUT
: /* optimized out */
2543 case LOC_ARG
: /* argument */
2544 case LOC_REF_ARG
: /* reference arg */
2545 case LOC_REGPARM
: /* register arg */
2546 case LOC_REGPARM_ADDR
: /* indirect register arg */
2547 case LOC_LOCAL_ARG
: /* stack arg */
2548 case LOC_BASEREG_ARG
: /* basereg arg */
2550 Tcl_ListObjAppendElement (interp
, result
,
2551 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2553 case LOC_LOCAL
: /* stack local */
2554 case LOC_BASEREG
: /* basereg local */
2556 Tcl_ListObjAppendElement (interp
, result
,
2557 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2561 if (BLOCK_FUNCTION (block
))
2564 block
= BLOCK_SUPERBLOCK (block
);
2567 Tcl_SetObjResult (interp
, result
);
2572 gdb_get_line_command (clientData
, interp
, objc
, objv
)
2573 ClientData clientData
;
2576 Tcl_Obj
*CONST objv
[];
2579 struct symtabs_and_lines sals
;
2580 char *args
, **canonical
;
2584 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2585 Tcl_GetStringFromObj (objv
[0], NULL
),
2590 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2591 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2592 if (sals
.nelts
== 1)
2594 Tcl_SetObjResult (interp
, Tcl_NewIntObj (sals
.sals
[0].line
));
2598 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2603 gdb_get_file_command (clientData
, interp
, objc
, objv
)
2604 ClientData clientData
;
2607 Tcl_Obj
*CONST objv
[];
2610 struct symtabs_and_lines sals
;
2611 char *args
, **canonical
;
2615 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2616 Tcl_GetStringFromObj (objv
[0], NULL
),
2621 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2622 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2623 if (sals
.nelts
== 1)
2625 Tcl_SetResult (interp
, sals
.sals
[0].symtab
->filename
, TCL_VOLATILE
);
2629 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2634 gdb_get_function_command (clientData
, interp
, objc
, objv
)
2635 ClientData clientData
;
2638 Tcl_Obj
*CONST objv
[];
2642 struct symtabs_and_lines sals
;
2643 char *args
, **canonical
;
2647 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2648 Tcl_GetStringFromObj (objv
[0], NULL
),
2653 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2654 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2655 if (sals
.nelts
== 1)
2657 resolve_sal_pc (&sals
.sals
[0]);
2658 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
2659 if (function
!= NULL
)
2661 Tcl_SetResult (interp
, function
, TCL_VOLATILE
);
2666 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2671 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
2672 ClientData clientData
;
2675 Tcl_Obj
*CONST objv
[];
2677 struct symtab_and_line sal
;
2679 struct tracepoint
*tp
;
2680 struct action_line
*al
;
2681 Tcl_Obj
*list
, *action_list
;
2682 char *filename
, *funcname
;
2686 error ("wrong # args");
2688 Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
);
2690 ALL_TRACEPOINTS (tp
)
2691 if (tp
->number
== tpnum
)
2695 error ("Tracepoint #%d does not exist", tpnum
);
2697 list
= Tcl_NewListObj (0, NULL
);
2698 sal
= find_pc_line (tp
->address
, 0);
2699 filename
= symtab_to_filename (sal
.symtab
);
2700 if (filename
== NULL
)
2702 Tcl_ListObjAppendElement (interp
, list
,
2703 Tcl_NewStringObj (filename
, -1));
2704 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
2705 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (funcname
, -1));
2706 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (sal
.line
));
2707 sprintf (tmp
, "0x%lx", tp
->address
);
2708 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (tmp
, -1));
2709 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->enabled
));
2710 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->pass_count
));
2711 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->step_count
));
2712 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->thread
));
2713 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->hit_count
));
2715 /* Append a list of actions */
2716 action_list
= Tcl_NewListObj (0, NULL
);
2717 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
2719 Tcl_ListObjAppendElement (interp
, action_list
,
2720 Tcl_NewStringObj (al
->action
, -1));
2722 Tcl_ListObjAppendElement (interp
, list
, action_list
);
2724 Tcl_SetObjResult (interp
, list
);
2729 /* TclDebug (const char *fmt, ...) works just like printf() but */
2730 /* sends the output to the GDB TK debug window. */
2731 /* Not for normal use; just a convenient tool for debugging */
2733 #ifdef ANSI_PROTOTYPES
2734 TclDebug (const char *fmt
, ...)
2741 char buf
[512], *v
[2], *merge
;
2743 #ifdef ANSI_PROTOTYPES
2744 va_start (args
, fmt
);
2748 fmt
= va_arg (args
, char *);
2754 vsprintf (buf
, fmt
, args
);
2757 merge
= Tcl_Merge (2, v
);
2758 Tcl_Eval (interp
, merge
);
2763 /* Find the full pathname to a file, searching the symbol tables */
2766 gdb_find_file_command (clientData
, interp
, objc
, objv
)
2767 ClientData clientData
;
2770 Tcl_Obj
*CONST objv
[];
2772 char *filename
= NULL
;
2777 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
2781 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
2783 filename
= st
->fullname
;
2785 if (filename
== NULL
)
2786 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("", 0));
2788 Tcl_SetObjResult (interp
, Tcl_NewStringObj (filename
, -1));
2794 gdbtk_create_tracepoint (tp
)
2795 struct tracepoint
*tp
;
2797 tracepoint_notify (tp
, "create");
2801 gdbtk_delete_tracepoint (tp
)
2802 struct tracepoint
*tp
;
2804 tracepoint_notify (tp
, "delete");
2808 gdbtk_modify_tracepoint (tp
)
2809 struct tracepoint
*tp
;
2811 tracepoint_notify (tp
, "modify");
2815 tracepoint_notify(tp
, action
)
2816 struct tracepoint
*tp
;
2821 struct symtab_and_line sal
;
2824 /* We ensure that ACTION contains no special Tcl characters, so we
2826 sal
= find_pc_line (tp
->address
, 0);
2828 filename
= symtab_to_filename (sal
.symtab
);
2829 if (filename
== NULL
)
2831 sprintf (buf
, "gdbtk_tcl_tracepoint %s %d 0x%lx %d {%s}", action
, tp
->number
,
2832 (long)tp
->address
, sal
.line
, filename
, tp
->pass_count
);
2834 v
= Tcl_Eval (interp
, buf
);
2838 gdbtk_fputs (interp
->result
, gdb_stdout
);
2839 gdbtk_fputs ("\n", gdb_stdout
);
2843 /* returns -1 if not found, tracepoint # if found */
2845 tracepoint_exists (char * args
)
2847 struct tracepoint
*tp
;
2849 struct symtabs_and_lines sals
;
2853 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2854 if (sals
.nelts
== 1)
2856 resolve_sal_pc (&sals
.sals
[0]);
2857 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
2858 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
2861 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
2862 strcat (file
, sals
.sals
[0].symtab
->filename
);
2864 ALL_TRACEPOINTS (tp
)
2866 if (tp
->address
== sals
.sals
[0].pc
)
2867 result
= tp
->number
;
2869 /* Why is this here? This messes up assembly traces */
2870 else if (tp
->source_file
!= NULL
2871 && strcmp (tp
->source_file
, file
) == 0
2872 && sals
.sals
[0].line
== tp
->line_number
)
2873 result
= tp
->number
;
2884 gdb_actions_command (clientData
, interp
, objc
, objv
)
2885 ClientData clientData
;
2888 Tcl_Obj
*CONST objv
[];
2890 struct tracepoint
*tp
;
2892 int nactions
, i
, len
;
2893 char *number
, *args
, *action
;
2895 struct action_line
*next
= NULL
, *temp
;
2899 Tcl_AppendResult (interp
, "wrong # args: should be: \"",
2900 Tcl_GetStringFromObj (objv
[0], NULL
),
2901 " number actions\"");
2905 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
2906 tp
= get_tracepoint_by_number (&args
);
2909 Tcl_AppendResult (interp
, "Tracepoint \"", number
, "\" does not exist");
2913 /* Free any existing actions */
2914 if (tp
->actions
!= NULL
)
2919 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
2920 for (i
= 0; i
< nactions
; i
++)
2922 temp
= xmalloc (sizeof (struct action_line
));
2924 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
2925 temp
->action
= savestring (action
, len
);
2926 if (sscanf (temp
->action
, "while-stepping %d", &step_count
) !=0)
2927 tp
->step_count
= step_count
;
2944 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
2945 ClientData clientData
;
2948 Tcl_Obj
*CONST objv
[];
2954 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2955 Tcl_GetStringFromObj (objv
[0], NULL
),
2956 " function:line|function|line|*addr\"");
2960 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2962 Tcl_SetObjResult (interp
, Tcl_NewIntObj (tracepoint_exists (args
)));
2966 /* Return the prompt to the interpreter */
2968 gdb_prompt_command (clientData
, interp
, objc
, objv
)
2969 ClientData clientData
;
2972 Tcl_Obj
*CONST objv
[];
2974 Tcl_SetResult (interp
, get_prompt (), TCL_VOLATILE
);
2978 /* return a list of all tracepoint numbers in interpreter */
2980 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
2981 ClientData clientData
;
2984 Tcl_Obj
*CONST objv
[];
2987 struct tracepoint
*tp
;
2989 list
= Tcl_NewListObj (0, NULL
);
2991 ALL_TRACEPOINTS (tp
)
2992 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->number
));
2994 Tcl_SetObjResult (interp
, list
);
2999 /* This hook is called whenever we are ready to load a symbol file so that
3000 the UI can notify the user... */
3002 gdbtk_pre_add_symbol (name
)
3007 v
[0] = "gdbtk_tcl_pre_add_symbol";
3009 merge
= Tcl_Merge (2, v
);
3010 Tcl_Eval (interp
, merge
);
3014 /* This hook is called whenever we finish loading a symbol file. */
3016 gdbtk_post_add_symbol ()
3018 Tcl_Eval (interp
, "gdbtk_tcl_post_add_symbol");
3024 gdbtk_print_frame_info (s
, line
, stopline
, noerror
)
3030 current_source_symtab
= s
;
3031 current_source_line
= line
;
3035 /* The lookup_symtab() in symtab.c doesn't work correctly */
3036 /* It will not work will full pathnames and if multiple */
3037 /* source files have the same basename, it will return */
3038 /* the first one instead of the correct one. This version */
3039 /* also always makes sure symtab->fullname is set. */
3041 static struct symtab
*
3042 full_lookup_symtab(file
)
3046 struct objfile
*objfile
;
3047 char *bfile
, *fullname
;
3048 struct partial_symtab
*pt
;
3053 /* first try a direct lookup */
3054 st
= lookup_symtab (file
);
3058 symtab_to_filename(st
);
3062 /* if the direct approach failed, try */
3063 /* looking up the basename and checking */
3064 /* all matches with the fullname */
3065 bfile
= basename (file
);
3066 ALL_SYMTABS (objfile
, st
)
3068 if (!strcmp (bfile
, basename(st
->filename
)))
3071 fullname
= symtab_to_filename (st
);
3073 fullname
= st
->fullname
;
3075 if (!strcmp (file
, fullname
))
3080 /* still no luck? look at psymtabs */
3081 ALL_PSYMTABS (objfile
, pt
)
3083 if (!strcmp (bfile
, basename(pt
->filename
)))
3085 st
= PSYMTAB_TO_SYMTAB (pt
);
3088 fullname
= symtab_to_filename (st
);
3089 if (!strcmp (file
, fullname
))
3098 /* gdb_loadfile loads a c source file into a text widget. */
3100 /* LTABLE_SIZE is the number of bytes to allocate for the */
3101 /* line table. Its size limits the maximum number of lines */
3102 /* in a file to 8 * LTABLE_SIZE. This memory is freed after */
3103 /* the file is loaded, so it is OK to make this very large. */
3104 /* Additional memory will be allocated if needed. */
3105 #define LTABLE_SIZE 20000
3108 gdb_loadfile (clientData
, interp
, objc
, objv
)
3109 ClientData clientData
;
3112 Tcl_Obj
*CONST objv
[];
3114 char *file
, *widget
, *line
, *buf
, msg
[128];
3115 int linenumbers
, ln
, anum
, lnum
, ltable_size
;
3116 Tcl_Obj
*a
[2], *b
[2], *cmd
;
3119 struct symtab
*symtab
;
3120 struct linetable_entry
*le
;
3124 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
3128 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
3129 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
3130 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
3132 if ((fp
= fopen ( file
, "r" )) == NULL
)
3135 symtab
= full_lookup_symtab (file
);
3138 sprintf(msg
, "File not found");
3139 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3144 /* Source linenumbers don't appear to be in order, and a sort is */
3145 /* too slow so the fastest solution is just to allocate a huge */
3146 /* array and set the array entry for each linenumber */
3148 ltable_size
= LTABLE_SIZE
;
3149 ltable
= (char *)malloc (LTABLE_SIZE
);
3152 sprintf(msg
, "Out of memory.");
3153 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3158 memset (ltable
, 0, LTABLE_SIZE
);
3160 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
3162 le
= symtab
->linetable
->item
;
3163 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
3165 lnum
= le
->line
>> 3;
3166 if (lnum
>= ltable_size
)
3169 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
3170 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
3172 if (new_ltable
== NULL
)
3174 sprintf(msg
, "Out of memory.");
3175 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3180 ltable
= new_ltable
;
3182 ltable
[lnum
] |= 1 << (le
->line
% 8);
3186 /* create an object with enough space, then grab its */
3187 /* buffer and sprintf directly into it. */
3188 a
[0] = Tcl_NewStringObj (ltable
, 1024);
3189 a
[1] = Tcl_NewListObj(0,NULL
);
3191 b
[0] = Tcl_NewStringObj (ltable
,1024);
3192 b
[1] = Tcl_NewStringObj ("source_tag", -1);
3193 Tcl_IncrRefCount (b
[0]);
3194 Tcl_IncrRefCount (b
[1]);
3195 line
= b
[0]->bytes
+ 1;
3196 strcpy(b
[0]->bytes
,"\t");
3199 while (fgets (line
, 980, fp
))
3203 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3204 a
[0]->length
= sprintf (buf
,"%s insert end {-\t%d} break_tag", widget
, ln
);
3206 a
[0]->length
= sprintf (buf
,"%s insert end { \t%d} \"\"", widget
, ln
);
3210 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3211 a
[0]->length
= sprintf (buf
,"%s insert end {-\t} break_tag", widget
);
3213 a
[0]->length
= sprintf (buf
,"%s insert end { \t} \"\"", widget
);
3215 b
[0]->length
= strlen(b
[0]->bytes
);
3216 Tcl_SetListObj(a
[1],2,b
);
3217 cmd
= Tcl_ConcatObj(2,a
);
3218 Tcl_EvalObj (interp
, cmd
);
3219 Tcl_DecrRefCount (cmd
);
3222 Tcl_DecrRefCount (b
[0]);
3223 Tcl_DecrRefCount (b
[0]);
3224 Tcl_DecrRefCount (b
[1]);
3225 Tcl_DecrRefCount (b
[1]);
3231 /* at some point make these static in breakpoint.c and move GUI code there */
3232 extern struct breakpoint
*set_raw_breakpoint (struct symtab_and_line sal
);
3233 extern void set_breakpoint_count (int);
3234 extern int breakpoint_count
;
3236 /* set a breakpoint by source file and line number */
3237 /* flags are as follows: */
3238 /* least significant 2 bits are disposition, rest is */
3239 /* type (normally 0).
3242 bp_breakpoint, Normal breakpoint
3243 bp_hardware_breakpoint, Hardware assisted breakpoint
3246 Disposition of breakpoint. Ie: what to do after hitting it.
3249 del_at_next_stop, Delete at next stop, whether hit or not
3251 donttouch Leave it alone
3256 gdb_set_bp (clientData
, interp
, objc
, objv
)
3257 ClientData clientData
;
3260 Tcl_Obj
*CONST objv
[];
3263 struct symtab_and_line sal
;
3264 int line
, flags
, ret
;
3265 struct breakpoint
*b
;
3267 Tcl_Obj
*a
[5], *cmd
;
3271 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
3275 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
3276 if (sal
.symtab
== NULL
)
3279 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
3282 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
3286 sal
.pc
= find_line_pc (sal
.symtab
, sal
.line
);
3290 sal
.section
= find_pc_overlay (sal
.pc
);
3291 b
= set_raw_breakpoint (sal
);
3292 set_breakpoint_count (breakpoint_count
+ 1);
3293 b
->number
= breakpoint_count
;
3294 b
->type
= flags
>> 2;
3295 b
->disposition
= flags
& 3;
3297 /* FIXME: this won't work for duplicate basenames! */
3298 sprintf (buf
, "%s:%d", basename(Tcl_GetStringFromObj( objv
[1], NULL
)), line
);
3299 b
->addr_string
= strsave (buf
);
3301 /* now send notification command back to GUI */
3302 sprintf (buf
, "0x%x", sal
.pc
);
3303 a
[0] = Tcl_NewStringObj ("gdbtk_tcl_breakpoint create", -1);
3304 a
[1] = Tcl_NewIntObj (b
->number
);
3305 a
[2] = Tcl_NewStringObj (buf
, -1);
3307 a
[4] = Tcl_NewListObj (1,&objv
[1]);
3308 cmd
= Tcl_ConcatObj(5,a
);
3309 ret
= Tcl_EvalObj (interp
, cmd
);
3310 Tcl_DecrRefCount (cmd
);
3315 /* The whole timer idea is an easy one, but POSIX does not appear to have
3316 some sort of interval timer requirement. Consequently, we cannot rely
3317 on cygwin32 to always deliver the timer's signal. This is especially
3318 painful given that all serial I/O will block the timer right now. */
3320 gdbtk_annotate_starting ()
3322 /* TclDebug ("### STARTING ###"); */
3323 gdbtk_start_timer ();
3327 gdbtk_annotate_stopped ()
3329 /* TclDebug ("### STOPPED ###"); */
3330 gdbtk_stop_timer ();
3334 gdbtk_annotate_exited ()
3336 /* TclDebug ("### EXITED ###"); */
3337 gdbtk_stop_timer ();
3341 gdbtk_annotate_signalled ()
3343 /* TclDebug ("### SIGNALLED ###"); */
3344 gdbtk_stop_timer ();
3348 /* Come here during initialize_all_files () */
3351 _initialize_gdbtk ()
3355 /* Tell the rest of the world that Gdbtk is now set up. */
3357 init_ui_hook
= gdbtk_init
;