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 call_obj_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
122 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
123 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
124 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
125 static void gdbtk_readline_end
PARAMS ((void));
126 static void pc_changed
PARAMS ((void));
127 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
128 static void register_changed_p
PARAMS ((int, void *));
129 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
130 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
131 static void breakpoint_notify
PARAMS ((struct breakpoint
*, const char *));
132 static void gdbtk_create_breakpoint
PARAMS ((struct breakpoint
*));
133 static void gdbtk_delete_breakpoint
PARAMS ((struct breakpoint
*));
134 static void gdbtk_modify_breakpoint
PARAMS ((struct breakpoint
*));
135 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
136 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
137 static int map_arg_registers
PARAMS ((int, char *[], void (*) (int, void *), void *));
138 static void get_register_name
PARAMS ((int, void *));
139 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
140 static void get_register
PARAMS ((int, void *));
141 static int gdb_trace_status
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
142 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
143 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
144 void TclDebug
PARAMS ((const char *fmt
, ...));
145 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
146 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
147 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
148 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
149 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
150 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
151 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
152 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
153 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
154 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
155 static void gdbtk_create_tracepoint
PARAMS ((struct tracepoint
*));
156 static void gdbtk_delete_tracepoint
PARAMS ((struct tracepoint
*));
157 static void gdbtk_modify_tracepoint
PARAMS ((struct tracepoint
*));
158 static void tracepoint_notify
PARAMS ((struct tracepoint
*, const char *));
159 static void gdbtk_print_frame_info
PARAMS ((struct symtab
*, int, int, int));
160 void gdbtk_pre_add_symbol
PARAMS ((char *));
161 void gdbtk_post_add_symbol
PARAMS ((void));
162 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
163 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
164 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
165 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
166 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
168 /* Handle for TCL interpreter */
169 static Tcl_Interp
*interp
= NULL
;
171 static int gdbtk_timer_going
= 0;
172 static void gdbtk_start_timer
PARAMS ((void));
173 static void gdbtk_stop_timer
PARAMS ((void));
175 /* This variable is true when the inferior is running. Although it's
176 possible to disable most input from widgets and thus prevent
177 attempts to do anything while the inferior is running, any commands
178 that get through - even a simple memory read - are Very Bad, and
179 may cause GDB to crash or behave strangely. So, this variable
180 provides an extra layer of defense. */
182 static int running_now
;
184 /* This variable determines where memory used for disassembly is read from.
185 If > 0, then disassembly comes from the exec file rather than the
186 target (which might be at the other end of a slow serial link). If
187 == 0 then disassembly comes from target. If < 0 disassembly is
188 automatically switched to the target if it's an inferior process,
189 otherwise the exec file is used. */
191 static int disassemble_from_exec
= -1;
195 /* Supply malloc calls for tcl/tk. We do not want to do this on
196 Windows, because Tcl_Alloc is probably in a DLL which will not call
197 the mmalloc routines. */
203 return xmalloc (size
);
207 Tcl_Realloc (ptr
, size
)
211 return xrealloc (ptr
, size
);
221 #endif /* ! _WIN32 */
231 /* On Windows, if we hold a file open, other programs can't write to
232 it. In particular, we don't want to hold the executable open,
233 because it will mean that people have to get out of the debugging
234 session in order to remake their program. So we close it, although
235 this will cost us if and when we need to reopen it. */
245 bfd_cache_close (o
->obfd
);
248 if (exec_bfd
!= NULL
)
249 bfd_cache_close (exec_bfd
);
254 /* The following routines deal with stdout/stderr data, which is created by
255 {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the
256 lowest level of these routines and capture all output from the rest of GDB.
257 Normally they present their data to tcl via callbacks to the following tcl
258 routines: gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush. These
259 in turn call tk routines to update the display.
261 Under some circumstances, you may want to collect the output so that it can
262 be returned as the value of a tcl procedure. This can be done by
263 surrounding the output routines with calls to start_saving_output and
264 finish_saving_output. The saved data can then be retrieved with
265 get_saved_output (but this must be done before the call to
266 finish_saving_output). */
268 /* Dynamic string for output. */
270 static Tcl_DString
*result_ptr
;
272 /* Dynamic string for stderr. This is only used if result_ptr is
275 static Tcl_DString
*error_string_ptr
;
282 /* Force immediate screen update */
284 Tcl_VarEval (interp
, "gdbtk_tcl_flush", NULL
);
289 gdbtk_fputs (ptr
, stream
)
293 char *merge
[2], *command
;
297 Tcl_DStringAppend (result_ptr
, (char *) ptr
, -1);
298 else if (error_string_ptr
!= NULL
&& stream
== gdb_stderr
)
299 Tcl_DStringAppend (error_string_ptr
, (char *) ptr
, -1);
302 merge
[0] = "gdbtk_tcl_fputs";
303 merge
[1] = (char *)ptr
;
304 command
= Tcl_Merge (2, merge
);
305 Tcl_Eval (interp
, command
);
312 gdbtk_warning (warning
, args
)
316 char buf
[200], *merge
[2];
319 vsprintf (buf
, warning
, args
);
320 merge
[0] = "gdbtk_tcl_warning";
322 command
= Tcl_Merge (2, merge
);
323 Tcl_Eval (interp
, command
);
328 gdbtk_ignorable_warning (warning
, args
)
332 char buf
[200], *merge
[2];
335 vsprintf (buf
, warning
, args
);
336 merge
[0] = "gdbtk_tcl_ignorable_warning";
338 command
= Tcl_Merge (2, merge
);
339 Tcl_Eval (interp
, command
);
344 gdbtk_query (query
, args
)
348 char buf
[200], *merge
[2];
352 vsprintf (buf
, query
, args
);
353 merge
[0] = "gdbtk_tcl_query";
355 command
= Tcl_Merge (2, merge
);
356 Tcl_Eval (interp
, command
);
359 val
= atol (interp
->result
);
365 #ifdef ANSI_PROTOTYPES
366 gdbtk_readline_begin (char *format
, ...)
368 gdbtk_readline_begin (va_alist
)
373 char buf
[200], *merge
[2];
376 #ifdef ANSI_PROTOTYPES
377 va_start (args
, format
);
381 format
= va_arg (args
, char *);
384 vsprintf (buf
, format
, args
);
385 merge
[0] = "gdbtk_tcl_readline_begin";
387 command
= Tcl_Merge (2, merge
);
388 Tcl_Eval (interp
, command
);
393 gdbtk_readline (prompt
)
404 merge
[0] = "gdbtk_tcl_readline";
406 command
= Tcl_Merge (2, merge
);
407 result
= Tcl_Eval (interp
, command
);
409 if (result
== TCL_OK
)
411 return (strdup (interp
-> result
));
415 gdbtk_fputs (interp
-> result
, gdb_stdout
);
416 gdbtk_fputs ("\n", gdb_stdout
);
422 gdbtk_readline_end ()
424 Tcl_Eval (interp
, "gdbtk_tcl_readline_end");
430 Tcl_Eval (interp
, "gdbtk_pc_changed");
435 #ifdef ANSI_PROTOTYPES
436 dsprintf_append_element (Tcl_DString
*dsp
, char *format
, ...)
438 dsprintf_append_element (va_alist
)
445 #ifdef ANSI_PROTOTYPES
446 va_start (args
, format
);
452 dsp
= va_arg (args
, Tcl_DString
*);
453 format
= va_arg (args
, char *);
456 vsprintf (buf
, format
, args
);
458 Tcl_DStringAppendElement (dsp
, buf
);
462 gdb_path_conv (clientData
, interp
, argc
, argv
)
463 ClientData clientData
;
469 char pathname
[256], *ptr
;
471 error ("wrong # args");
472 cygwin32_conv_to_full_win32_path (argv
[1], pathname
);
473 for (ptr
= pathname
; *ptr
; ptr
++)
479 char *pathname
= argv
[1];
481 Tcl_DStringAppend (result_ptr
, pathname
, strlen(pathname
));
486 gdb_get_breakpoint_list (clientData
, interp
, argc
, argv
)
487 ClientData clientData
;
492 struct breakpoint
*b
;
493 extern struct breakpoint
*breakpoint_chain
;
496 error ("wrong # args");
498 for (b
= breakpoint_chain
; b
; b
= b
->next
)
499 if (b
->type
== bp_breakpoint
)
500 dsprintf_append_element (result_ptr
, "%d", b
->number
);
506 gdb_get_breakpoint_info (clientData
, interp
, argc
, argv
)
507 ClientData clientData
;
512 struct symtab_and_line sal
;
513 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
514 "finish", "watchpoint", "hardware watchpoint",
515 "read watchpoint", "access watchpoint",
516 "longjmp", "longjmp resume", "step resume",
517 "through sigtramp", "watchpoint scope",
519 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
520 struct command_line
*cmd
;
522 struct breakpoint
*b
;
523 extern struct breakpoint
*breakpoint_chain
;
524 char *funcname
, *fname
, *filename
;
527 error ("wrong # args");
529 bpnum
= atoi (argv
[1]);
531 for (b
= breakpoint_chain
; b
; b
= b
->next
)
532 if (b
->number
== bpnum
)
535 if (!b
|| b
->type
!= bp_breakpoint
)
536 error ("Breakpoint #%d does not exist", bpnum
);
538 sal
= find_pc_line (b
->address
, 0);
540 filename
= symtab_to_filename (sal
.symtab
);
541 if (filename
== NULL
)
543 Tcl_DStringAppendElement (result_ptr
, filename
);
545 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
546 fname
= cplus_demangle (funcname
, 0);
549 Tcl_DStringAppendElement (result_ptr
, fname
);
553 Tcl_DStringAppendElement (result_ptr
, funcname
);
554 dsprintf_append_element (result_ptr
, "%d", b
->line_number
);
555 dsprintf_append_element (result_ptr
, "0x%lx", b
->address
);
556 Tcl_DStringAppendElement (result_ptr
, bptypes
[b
->type
]);
557 Tcl_DStringAppendElement (result_ptr
, b
->enable
== enabled
? "1" : "0");
558 Tcl_DStringAppendElement (result_ptr
, bpdisp
[b
->disposition
]);
559 dsprintf_append_element (result_ptr
, "%d", b
->ignore_count
);
561 Tcl_DStringStartSublist (result_ptr
);
562 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
563 Tcl_DStringAppendElement (result_ptr
, cmd
->line
);
564 Tcl_DStringEndSublist (result_ptr
);
566 Tcl_DStringAppendElement (result_ptr
, b
->cond_string
);
568 dsprintf_append_element (result_ptr
, "%d", b
->thread
);
569 dsprintf_append_element (result_ptr
, "%d", b
->hit_count
);
575 breakpoint_notify(b
, action
)
576 struct breakpoint
*b
;
581 struct symtab_and_line sal
;
584 if (b
->type
!= bp_breakpoint
)
587 /* We ensure that ACTION contains no special Tcl characters, so we
589 sal
= find_pc_line (b
->address
, 0);
590 filename
= symtab_to_filename (sal
.symtab
);
591 if (filename
== NULL
)
594 sprintf (buf
, "gdbtk_tcl_breakpoint %s %d 0x%lx %d {%s}", action
, b
->number
,
595 (long)b
->address
, b
->line_number
, filename
);
597 v
= Tcl_Eval (interp
, buf
);
601 gdbtk_fputs (interp
->result
, gdb_stdout
);
602 gdbtk_fputs ("\n", gdb_stdout
);
607 gdbtk_create_breakpoint(b
)
608 struct breakpoint
*b
;
610 breakpoint_notify (b
, "create");
614 gdbtk_delete_breakpoint(b
)
615 struct breakpoint
*b
;
617 breakpoint_notify (b
, "delete");
621 gdbtk_modify_breakpoint(b
)
622 struct breakpoint
*b
;
624 breakpoint_notify (b
, "modify");
627 /* This implements the TCL command `gdb_loc', which returns a list */
628 /* consisting of the following: */
629 /* basename, function name, filename, line number, address, current pc */
632 gdb_loc (clientData
, interp
, argc
, argv
)
633 ClientData clientData
;
639 struct symtab_and_line sal
;
640 char *funcname
, *fname
;
643 if (!have_full_symbols () && !have_partial_symbols ())
645 Tcl_SetResult (interp
, "No symbol table is loaded", TCL_STATIC
);
651 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
653 /* Note - this next line is not correct on all architectures. */
654 /* For a graphical debugged we really want to highlight the */
655 /* assembly line that called the next function on the stack. */
656 /* Many architectures have the next instruction saved as the */
657 /* pc on the stack, so what happens is the next instruction is hughlighted. */
659 pc
= selected_frame
->pc
;
660 sal
= find_pc_line (selected_frame
->pc
,
661 selected_frame
->next
!= NULL
662 && !selected_frame
->next
->signal_handler_caller
663 && !frame_in_dummy (selected_frame
->next
));
668 sal
= find_pc_line (stop_pc
, 0);
673 struct symtabs_and_lines sals
;
676 sals
= decode_line_spec (argv
[1], 1);
683 error ("Ambiguous line spec");
688 error ("wrong # args");
691 Tcl_DStringAppendElement (result_ptr
, sal
.symtab
->filename
);
693 Tcl_DStringAppendElement (result_ptr
, "");
695 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
696 fname
= cplus_demangle (funcname
, 0);
699 Tcl_DStringAppendElement (result_ptr
, fname
);
703 Tcl_DStringAppendElement (result_ptr
, funcname
);
704 filename
= symtab_to_filename (sal
.symtab
);
705 if (filename
== NULL
)
708 Tcl_DStringAppendElement (result_ptr
, filename
);
709 dsprintf_append_element (result_ptr
, "%d", sal
.line
); /* line number */
710 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
711 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
715 /* This implements the TCL command `gdb_eval'. */
718 gdb_eval (clientData
, interp
, argc
, argv
)
719 ClientData clientData
;
724 struct expression
*expr
;
725 struct cleanup
*old_chain
;
729 error ("wrong # args");
731 expr
= parse_expression (argv
[1]);
733 old_chain
= make_cleanup (free_current_contents
, &expr
);
735 val
= evaluate_expression (expr
);
737 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
738 gdb_stdout
, 0, 0, 0, 0);
740 do_cleanups (old_chain
);
745 /* gdb_get_mem addr form size num aschar*/
746 /* dump a block of memory */
747 /* addr: address of data to dump */
748 /* form: a char indicating format */
749 /* size: size of each element; 1,2,4, or 8 bytes*/
750 /* num: the number of bytes to read */
751 /* acshar: an optional ascii character to use in ASCII dump */
752 /* returns a list of elements followed by an optional */
756 gdb_get_mem (clientData
, interp
, argc
, argv
)
757 ClientData clientData
;
762 int size
, asize
, i
, j
, bc
;
764 int nbytes
, rnum
, bpr
;
765 char format
, c
, *ptr
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
766 struct type
*val_type
;
768 if (argc
< 6 || argc
> 7)
770 interp
->result
= "addr format size bytes bytes_per_row ?ascii_char?";
774 size
= (int)strtoul(argv
[3],(char **)NULL
,0);
775 nbytes
= (int)strtoul(argv
[4],(char **)NULL
,0);
776 bpr
= (int)strtoul(argv
[5],(char **)NULL
,0);
777 if (nbytes
<= 0 || bpr
<= 0 || size
<= 0)
779 interp
->result
= "Invalid number of bytes.";
783 addr
= (CORE_ADDR
)strtoul(argv
[1],(char **)NULL
,0);
785 mbuf
= (char *)malloc (nbytes
+32);
788 interp
->result
= "Out of memory.";
791 memset (mbuf
, 0, nbytes
+32);
794 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
803 val_type
= builtin_type_char
;
807 val_type
= builtin_type_short
;
811 val_type
= builtin_type_int
;
815 val_type
= builtin_type_long_long
;
819 val_type
= builtin_type_char
;
823 bc
= 0; /* count of bytes in a row */
824 buff
[0] = '"'; /* buffer for ascii dump */
825 bptr
= &buff
[1]; /* pointer for ascii dump */
827 for (i
=0; i
< nbytes
; i
+= size
)
831 fputs_unfiltered ("N/A ", gdb_stdout
);
833 for ( j
= 0; j
< size
; j
++)
838 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
839 fputs_unfiltered (" ", gdb_stdout
);
842 for ( j
= 0; j
< size
; j
++)
845 if (c
< 32 || c
> 126)
857 if (aschar
&& (bc
>= bpr
))
859 /* end of row. print it and reset variables */
864 fputs_unfiltered (buff
, gdb_stdout
);
874 map_arg_registers (argc
, argv
, func
, argp
)
877 void (*func
) PARAMS ((int regnum
, void *argp
));
882 /* Note that the test for a valid register must include checking the
883 reg_names array because NUM_REGS may be allocated for the union of the
884 register sets within a family of related processors. In this case, the
885 trailing entries of reg_names will change depending upon the particular
886 processor being debugged. */
888 if (argc
== 0) /* No args, just do all the regs */
892 && reg_names
[regnum
] != NULL
893 && *reg_names
[regnum
] != '\000';
900 /* Else, list of register #s, just do listed regs */
901 for (; argc
> 0; argc
--, argv
++)
903 regnum
= atoi (*argv
);
907 && reg_names
[regnum
] != NULL
908 && *reg_names
[regnum
] != '\000')
911 error ("bad register number");
918 get_register_name (regnum
, argp
)
920 void *argp
; /* Ignored */
922 Tcl_DStringAppendElement (result_ptr
, reg_names
[regnum
]);
925 /* This implements the TCL command `gdb_regnames', which returns a list of
926 all of the register names. */
929 gdb_regnames (clientData
, interp
, argc
, argv
)
930 ClientData clientData
;
938 return map_arg_registers (argc
, argv
, get_register_name
, NULL
);
941 #ifndef REGISTER_CONVERTIBLE
942 #define REGISTER_CONVERTIBLE(x) (0 != 0)
945 #ifndef REGISTER_CONVERT_TO_VIRTUAL
946 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
949 #ifndef INVALID_FLOAT
950 #define INVALID_FLOAT(x, y) (0 != 0)
954 get_register (regnum
, fp
)
958 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
959 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
960 int format
= (int)fp
;
965 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
967 Tcl_DStringAppendElement (result_ptr
, "Optimized out");
971 /* Convert raw data to virtual format if necessary. */
973 if (REGISTER_CONVERTIBLE (regnum
))
975 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
976 raw_buffer
, virtual_buffer
);
979 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
984 printf_filtered ("0x");
985 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
987 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
988 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
989 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
993 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
994 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
996 Tcl_DStringAppend (result_ptr
, " ", -1);
1000 get_pc_register (clientData
, interp
, argc
, argv
)
1001 ClientData clientData
;
1006 sprintf(interp
->result
,"0x%llx",(long long)read_register(PC_REGNUM
));
1011 gdb_fetch_registers (clientData
, interp
, argc
, argv
)
1012 ClientData clientData
;
1020 error ("wrong # args");
1026 return map_arg_registers (argc
, argv
, get_register
, (void *) format
);
1029 /* This contains the previous values of the registers, since the last call to
1030 gdb_changed_register_list. */
1032 static char old_regs
[REGISTER_BYTES
];
1035 register_changed_p (regnum
, argp
)
1037 void *argp
; /* Ignored */
1039 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1041 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1044 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1045 REGISTER_RAW_SIZE (regnum
)) == 0)
1048 /* Found a changed register. Save new value and return its number. */
1050 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1051 REGISTER_RAW_SIZE (regnum
));
1053 dsprintf_append_element (result_ptr
, "%d", regnum
);
1057 gdb_changed_register_list (clientData
, interp
, argc
, argv
)
1058 ClientData clientData
;
1066 return map_arg_registers (argc
, argv
, register_changed_p
, NULL
);
1069 /* This implements the tcl command "gdb_immediate", which does exactly
1070 the same thing as gdb_cmd, except NONE of its outut is buffered. */
1071 /* This will also ALWAYS cause the busy,update, and idle hooks to be
1072 called, contrasted with gdb_cmd, which NEVER calls them. */
1074 gdb_immediate_command (clientData
, interp
, argc
, argv
)
1075 ClientData clientData
;
1080 Tcl_DString
*save_ptr
= NULL
;
1083 error ("wrong # args");
1085 if (running_now
|| load_in_progress
)
1090 Tcl_DStringAppend (result_ptr
, "", -1);
1091 save_ptr
= result_ptr
;
1094 execute_command (argv
[1], 1);
1096 bpstat_do_actions (&stop_bpstat
);
1098 result_ptr
= save_ptr
;
1103 /* This implements the TCL command `gdb_cmd', which sends its argument into
1104 the GDB command scanner. */
1105 /* This command will never cause the update, idle and busy hooks to be called
1108 gdb_cmd (clientData
, interp
, argc
, argv
)
1109 ClientData clientData
;
1114 Tcl_DString
*save_ptr
= NULL
;
1117 error ("wrong # args");
1119 if (running_now
|| load_in_progress
)
1124 /* for the load instruction (and possibly others later) we
1125 set result_ptr to NULL so gdbtk_fputs() will not buffer
1126 all the data until the command is finished. */
1128 if (strncmp ("load ", argv
[1], 5) == 0
1129 || strncmp ("while ", argv
[1], 6) == 0)
1131 Tcl_DStringAppend (result_ptr
, "", -1);
1132 save_ptr
= result_ptr
;
1134 load_in_progress
= 1;
1135 gdbtk_start_timer ();
1138 execute_command (argv
[1], 1);
1140 if (load_in_progress
)
1142 gdbtk_stop_timer ();
1143 load_in_progress
= 0;
1146 bpstat_do_actions (&stop_bpstat
);
1149 result_ptr
= save_ptr
;
1154 /* Client of call_wrapper - this routine performs the actual call to
1155 the client function. */
1157 struct wrapped_call_args
1168 struct wrapped_call_args
*args
;
1170 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->argc
, args
->argv
);
1174 struct wrapped_call_objs
1184 wrapped_obj_call (args
)
1185 struct wrapped_call_objs
*args
;
1187 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->objc
, args
->objv
);
1191 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
1192 handles cleanups, and calls to return_to_top_level (usually via error).
1193 This is necessary in order to prevent a longjmp out of the bowels of Tk,
1194 possibly leaving things in a bad state. Since this routine can be called
1195 recursively, it needs to save and restore the contents of the jmp_buf as
1199 call_wrapper (clientData
, interp
, argc
, argv
)
1200 ClientData clientData
;
1205 struct wrapped_call_args wrapped_args
;
1206 Tcl_DString result
, *old_result_ptr
;
1207 Tcl_DString error_string
, *old_error_string_ptr
;
1209 Tcl_DStringInit (&result
);
1210 old_result_ptr
= result_ptr
;
1211 result_ptr
= &result
;
1213 Tcl_DStringInit (&error_string
);
1214 old_error_string_ptr
= error_string_ptr
;
1215 error_string_ptr
= &error_string
;
1217 wrapped_args
.func
= (Tcl_CmdProc
*)clientData
;
1218 wrapped_args
.interp
= interp
;
1219 wrapped_args
.argc
= argc
;
1220 wrapped_args
.argv
= argv
;
1221 wrapped_args
.val
= 0;
1223 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
1225 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
1227 /* Make sure the timer interrupts are turned off. */
1228 if (gdbtk_timer_going
)
1229 gdbtk_stop_timer ();
1231 gdb_flush (gdb_stderr
); /* Flush error output */
1232 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
1234 /* In case of an error, we may need to force the GUI into idle
1235 mode because gdbtk_call_command may have bombed out while in
1236 the command routine. */
1239 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1242 /* do not suppress any errors -- a remote target could have errored */
1243 load_in_progress
= 0;
1245 if (Tcl_DStringLength (&error_string
) == 0)
1247 Tcl_DStringResult (interp
, &result
);
1248 Tcl_DStringFree (&error_string
);
1250 else if (Tcl_DStringLength (&result
) == 0)
1252 Tcl_DStringResult (interp
, &error_string
);
1253 Tcl_DStringFree (&result
);
1254 Tcl_DStringFree (&error_string
);
1258 Tcl_ResetResult (interp
);
1259 Tcl_AppendResult (interp
, Tcl_DStringValue (&result
),
1260 Tcl_DStringValue (&error_string
), (char *) NULL
);
1261 Tcl_DStringFree (&result
);
1262 Tcl_DStringFree (&error_string
);
1265 result_ptr
= old_result_ptr
;
1266 error_string_ptr
= old_error_string_ptr
;
1272 return wrapped_args
.val
;
1275 call_obj_wrapper (clientData
, interp
, objc
, objv
)
1276 ClientData clientData
;
1279 Tcl_Obj
*CONST objv
[];
1281 struct wrapped_call_objs wrapped_args
;
1282 Tcl_DString result
, *old_result_ptr
;
1283 Tcl_DString error_string
, *old_error_string_ptr
;
1285 /* The obj call wrapper works differently from the string wrapper, because
1286 * the obj calls currently insert their results directly into the
1287 * interpreter's result. So there is no need to have a result_ptr...
1288 * FIXME - rewrite all the object commands so they use a result_obj_ptr
1289 * - rewrite all the string commands to be object commands.
1292 Tcl_DStringInit (&result
);
1293 old_result_ptr
= result_ptr
;
1294 result_ptr
= &result
;
1296 Tcl_DStringInit (&error_string
);
1298 Tcl_DStringInit (&error_string
);
1299 old_error_string_ptr
= error_string_ptr
;
1300 error_string_ptr
= &error_string
;
1302 wrapped_args
.func
= (Tcl_CmdProc
*)clientData
;
1303 wrapped_args
.interp
= interp
;
1304 wrapped_args
.objc
= objc
;
1305 wrapped_args
.objv
= objv
;
1306 wrapped_args
.val
= 0;
1308 if (!catch_errors (wrapped_obj_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
1310 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
1312 /* Make sure the timer interrupts are turned off. */
1313 if (gdbtk_timer_going
)
1314 gdbtk_stop_timer ();
1316 gdb_flush (gdb_stderr
); /* Flush error output */
1317 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
1319 /* In case of an error, we may need to force the GUI into idle
1320 mode because gdbtk_call_command may have bombed out while in
1321 the command routine. */
1324 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1327 /* do not suppress any errors -- a remote target could have errored */
1328 load_in_progress
= 0;
1330 if (Tcl_DStringLength (&error_string
) == 0)
1332 /* We should insert the result here, but the obj commands now
1333 * do this directly, so we don't need to.
1334 * FIXME - ultimately, all this should be redone so that all the
1335 * commands either manipulate the Tcl result directly, or use a result_ptr.
1338 Tcl_DStringFree (&error_string
);
1340 else if (*(Tcl_GetStringResult (interp
)) == '\0')
1342 Tcl_DStringResult (interp
, &error_string
);
1343 Tcl_DStringFree (&error_string
);
1347 Tcl_AppendToObj(Tcl_GetObjResult(interp
), Tcl_DStringValue (&error_string
),
1348 Tcl_DStringLength (&error_string
));
1349 Tcl_DStringFree (&error_string
);
1352 result_ptr
= old_result_ptr
;
1353 error_string_ptr
= old_error_string_ptr
;
1359 return wrapped_args
.val
;
1363 comp_files (file1
, file2
)
1364 const char *file1
[], *file2
[];
1366 return strcmp(*file1
,*file2
);
1370 gdb_listfiles (clientData
, interp
, objc
, objv
)
1371 ClientData clientData
;
1374 Tcl_Obj
*CONST objv
[];
1376 struct objfile
*objfile
;
1377 struct partial_symtab
*psymtab
;
1378 struct symtab
*symtab
;
1379 char *lastfile
, *pathname
, **files
;
1381 int i
, numfiles
= 0, len
= 0;
1385 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1389 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1393 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1395 mylist
= Tcl_NewListObj (0, NULL
);
1397 ALL_PSYMTABS (objfile
, psymtab
)
1399 if (numfiles
== files_size
)
1401 files_size
= files_size
* 2;
1402 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1406 if (psymtab
->filename
)
1407 files
[numfiles
++] = basename(psymtab
->filename
);
1409 else if (!strcmp(psymtab
->filename
,basename(psymtab
->filename
))
1410 || !strncmp(pathname
,psymtab
->filename
,len
))
1411 if (psymtab
->filename
)
1412 files
[numfiles
++] = basename(psymtab
->filename
);
1415 ALL_SYMTABS (objfile
, symtab
)
1417 if (numfiles
== files_size
)
1419 files_size
= files_size
* 2;
1420 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1424 if (symtab
->filename
)
1425 files
[numfiles
++] = basename(symtab
->filename
);
1427 else if (!strcmp(symtab
->filename
,basename(symtab
->filename
))
1428 || !strncmp(pathname
,symtab
->filename
,len
))
1429 if (symtab
->filename
)
1430 files
[numfiles
++] = basename(symtab
->filename
);
1433 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1436 for (i
= 0; i
< numfiles
; i
++)
1438 if (strcmp(files
[i
],lastfile
))
1439 Tcl_ListObjAppendElement (interp
, mylist
, Tcl_NewStringObj(files
[i
], -1));
1440 lastfile
= files
[i
];
1442 Tcl_SetObjResult (interp
, mylist
);
1448 gdb_listfuncs (clientData
, interp
, argc
, argv
)
1449 ClientData clientData
;
1454 struct symtab
*symtab
;
1455 struct blockvector
*bv
;
1462 error ("wrong # args");
1464 symtab
= full_lookup_symtab (argv
[1]);
1466 error ("No such file");
1468 bv
= BLOCKVECTOR (symtab
);
1469 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1471 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1472 /* Skip the sort if this block is always sorted. */
1473 if (!BLOCK_SHOULD_SORT (b
))
1474 sort_block_syms (b
);
1475 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1477 sym
= BLOCK_SYM (b
, j
);
1478 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1481 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1484 sprintf (buf
,"{%s} 1", name
);
1487 sprintf (buf
,"{%s} 0", SYMBOL_NAME(sym
));
1488 Tcl_DStringAppendElement (result_ptr
, buf
);
1496 target_stop_wrapper (args
)
1504 gdb_stop (clientData
, interp
, argc
, argv
)
1505 ClientData clientData
;
1512 catch_errors (target_stop_wrapper
, NULL
, "",
1516 quit_flag
= 1; /* hope something sees this */
1521 /* Prepare to accept a new executable file. This is called when we
1522 want to clear away everything we know about the old file, without
1523 asking the user. The Tcl code will have already asked the user if
1524 necessary. After this is called, we should be able to run the
1525 `file' command without getting any questions. */
1528 gdb_clear_file (clientData
, interp
, argc
, argv
)
1529 ClientData clientData
;
1534 if (inferior_pid
!= 0 && target_has_execution
)
1537 target_detach (NULL
, 0);
1542 if (target_has_execution
)
1545 symbol_file_command (NULL
, 0);
1547 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
1548 clear it here. FIXME: This seems like an abstraction violation
1555 /* Ask the user to confirm an exit request. */
1558 gdb_confirm_quit (clientData
, interp
, argc
, argv
)
1559 ClientData clientData
;
1566 ret
= quit_confirm ();
1567 Tcl_DStringAppendElement (result_ptr
, ret
? "1" : "0");
1571 /* Quit without asking for confirmation. */
1574 gdb_force_quit (clientData
, interp
, argc
, argv
)
1575 ClientData clientData
;
1580 quit_force ((char *) NULL
, 1);
1584 /* This implements the TCL command `gdb_disassemble'. */
1587 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
1591 disassemble_info
*info
;
1593 extern struct target_ops exec_ops
;
1597 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
1608 /* We need a different sort of line table from the normal one cuz we can't
1609 depend upon implicit line-end pc's for lines. This is because of the
1610 reordering we are about to do. */
1612 struct my_line_entry
{
1619 compare_lines (mle1p
, mle2p
)
1623 struct my_line_entry
*mle1
, *mle2
;
1626 mle1
= (struct my_line_entry
*) mle1p
;
1627 mle2
= (struct my_line_entry
*) mle2p
;
1629 val
= mle1
->line
- mle2
->line
;
1634 return mle1
->start_pc
- mle2
->start_pc
;
1638 gdb_disassemble (clientData
, interp
, argc
, argv
)
1639 ClientData clientData
;
1644 CORE_ADDR pc
, low
, high
;
1645 int mixed_source_and_assembly
;
1646 static disassemble_info di
;
1647 static int di_initialized
;
1649 if (! di_initialized
)
1651 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
1652 (fprintf_ftype
) fprintf_unfiltered
);
1653 di
.flavour
= bfd_target_unknown_flavour
;
1654 di
.memory_error_func
= dis_asm_memory_error
;
1655 di
.print_address_func
= dis_asm_print_address
;
1659 di
.mach
= tm_print_insn_info
.mach
;
1660 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
1661 di
.endian
= BFD_ENDIAN_BIG
;
1663 di
.endian
= BFD_ENDIAN_LITTLE
;
1665 if (argc
!= 3 && argc
!= 4)
1666 error ("wrong # args");
1668 if (strcmp (argv
[1], "source") == 0)
1669 mixed_source_and_assembly
= 1;
1670 else if (strcmp (argv
[1], "nosource") == 0)
1671 mixed_source_and_assembly
= 0;
1673 error ("First arg must be 'source' or 'nosource'");
1675 low
= parse_and_eval_address (argv
[2]);
1679 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
1680 error ("No function contains specified address");
1683 high
= parse_and_eval_address (argv
[3]);
1685 /* If disassemble_from_exec == -1, then we use the following heuristic to
1686 determine whether or not to do disassembly from target memory or from the
1689 If we're debugging a local process, read target memory, instead of the
1690 exec file. This makes disassembly of functions in shared libs work
1693 Else, we're debugging a remote process, and should disassemble from the
1694 exec file for speed. However, this is no good if the target modifies its
1695 code (for relocation, or whatever).
1698 if (disassemble_from_exec
== -1)
1699 if (strcmp (target_shortname
, "child") == 0
1700 || strcmp (target_shortname
, "procfs") == 0
1701 || strcmp (target_shortname
, "vxprocess") == 0)
1702 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
1704 disassemble_from_exec
= 1; /* It's remote, read the exec file */
1706 if (disassemble_from_exec
)
1707 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
1709 di
.read_memory_func
= dis_asm_read_memory
;
1711 /* If just doing straight assembly, all we need to do is disassemble
1712 everything between low and high. If doing mixed source/assembly, we've
1713 got a totally different path to follow. */
1715 if (mixed_source_and_assembly
)
1716 { /* Come here for mixed source/assembly */
1717 /* The idea here is to present a source-O-centric view of a function to
1718 the user. This means that things are presented in source order, with
1719 (possibly) out of order assembly immediately following. */
1720 struct symtab
*symtab
;
1721 struct linetable_entry
*le
;
1724 struct my_line_entry
*mle
;
1725 struct symtab_and_line sal
;
1730 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
1735 /* First, convert the linetable to a bunch of my_line_entry's. */
1737 le
= symtab
->linetable
->item
;
1738 nlines
= symtab
->linetable
->nitems
;
1743 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
1747 /* Copy linetable entries for this function into our data structure, creating
1748 end_pc's and setting out_of_order as appropriate. */
1750 /* First, skip all the preceding functions. */
1752 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
1754 /* Now, copy all entries before the end of this function. */
1757 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
1759 if (le
[i
].line
== le
[i
+ 1].line
1760 && le
[i
].pc
== le
[i
+ 1].pc
)
1761 continue; /* Ignore duplicates */
1763 mle
[newlines
].line
= le
[i
].line
;
1764 if (le
[i
].line
> le
[i
+ 1].line
)
1766 mle
[newlines
].start_pc
= le
[i
].pc
;
1767 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
1771 /* If we're on the last line, and it's part of the function, then we need to
1772 get the end pc in a special way. */
1777 mle
[newlines
].line
= le
[i
].line
;
1778 mle
[newlines
].start_pc
= le
[i
].pc
;
1779 sal
= find_pc_line (le
[i
].pc
, 0);
1780 mle
[newlines
].end_pc
= sal
.end
;
1784 /* Now, sort mle by line #s (and, then by addresses within lines). */
1787 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
1789 /* Now, for each line entry, emit the specified lines (unless they have been
1790 emitted before), followed by the assembly code for that line. */
1792 next_line
= 0; /* Force out first line */
1793 for (i
= 0; i
< newlines
; i
++)
1795 /* Print out everything from next_line to the current line. */
1797 if (mle
[i
].line
>= next_line
)
1800 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
1802 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
1804 next_line
= mle
[i
].line
+ 1;
1807 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
1810 fputs_unfiltered (" ", gdb_stdout
);
1811 print_address (pc
, gdb_stdout
);
1812 fputs_unfiltered (":\t ", gdb_stdout
);
1813 pc
+= (*tm_print_insn
) (pc
, &di
);
1814 fputs_unfiltered ("\n", gdb_stdout
);
1821 for (pc
= low
; pc
< high
; )
1824 fputs_unfiltered (" ", gdb_stdout
);
1825 print_address (pc
, gdb_stdout
);
1826 fputs_unfiltered (":\t ", gdb_stdout
);
1827 pc
+= (*tm_print_insn
) (pc
, &di
);
1828 fputs_unfiltered ("\n", gdb_stdout
);
1832 gdb_flush (gdb_stdout
);
1838 tk_command (cmd
, from_tty
)
1844 struct cleanup
*old_chain
;
1846 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1848 error_no_arg ("tcl command to interpret");
1850 retval
= Tcl_Eval (interp
, cmd
);
1852 result
= strdup (interp
->result
);
1854 old_chain
= make_cleanup (free
, result
);
1856 if (retval
!= TCL_OK
)
1859 printf_unfiltered ("%s\n", result
);
1861 do_cleanups (old_chain
);
1865 cleanup_init (ignored
)
1869 Tcl_DeleteInterp (interp
);
1873 /* Come here during long calculations to check for GUI events. Usually invoked
1874 via the QUIT macro. */
1877 gdbtk_interactive ()
1879 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1882 /* Come here when there is activity on the X file descriptor. */
1888 static int in_x_event
= 0;
1889 static Tcl_Obj
*varname
= NULL
;
1890 if (in_x_event
|| in_fputs
)
1895 /* Process pending events */
1896 while (Tcl_DoOneEvent (TCL_DONT_WAIT
|TCL_ALL_EVENTS
) != 0)
1899 if (load_in_progress
)
1902 if (varname
== NULL
)
1904 Tcl_Obj
*varnamestrobj
= Tcl_NewStringObj("download_cancel_ok",-1);
1905 varname
= Tcl_ObjGetVar2(interp
,varnamestrobj
,NULL
,TCL_GLOBAL_ONLY
);
1907 if ((Tcl_GetIntFromObj(interp
,varname
,&val
) == TCL_OK
) && val
)
1921 /* For Cygwin32, we use a timer to periodically check for Windows
1922 messages. FIXME: It would be better to not poll, but to instead
1923 rewrite the target_wait routines to serve as input sources.
1924 Unfortunately, that will be a lot of work. */
1925 static sigset_t nullsigmask
;
1926 static struct sigaction act1
, act2
;
1927 static struct itimerval it_on
, it_off
;
1930 gdbtk_start_timer ()
1932 static int first
= 1;
1933 /*TclDebug ("Starting timer....");*/
1936 /* first time called, set up all the structs */
1938 sigemptyset (&nullsigmask
);
1940 act1
.sa_handler
= x_event
;
1941 act1
.sa_mask
= nullsigmask
;
1944 act2
.sa_handler
= SIG_IGN
;
1945 act2
.sa_mask
= nullsigmask
;
1948 it_on
.it_interval
.tv_sec
= 0;
1949 it_on
.it_interval
.tv_usec
= 250000; /* .25 sec */
1950 it_on
.it_value
.tv_sec
= 0;
1951 it_on
.it_value
.tv_usec
= 250000;
1953 it_off
.it_interval
.tv_sec
= 0;
1954 it_off
.it_interval
.tv_usec
= 0;
1955 it_off
.it_value
.tv_sec
= 0;
1956 it_off
.it_value
.tv_usec
= 0;
1959 if (!gdbtk_timer_going
)
1961 sigaction (SIGALRM
, &act1
, NULL
);
1962 setitimer (ITIMER_REAL
, &it_on
, NULL
);
1963 gdbtk_timer_going
= 1;
1970 if (gdbtk_timer_going
)
1972 gdbtk_timer_going
= 0;
1973 /*TclDebug ("Stopping timer.");*/
1974 setitimer (ITIMER_REAL
, &it_off
, NULL
);
1975 sigaction (SIGALRM
, &act2
, NULL
);
1979 /* This hook function is called whenever we want to wait for the
1983 gdbtk_wait (pid
, ourstatus
)
1985 struct target_waitstatus
*ourstatus
;
1987 gdbtk_start_timer ();
1988 pid
= target_wait (pid
, ourstatus
);
1989 gdbtk_stop_timer ();
1993 /* This is called from execute_command, and provides a wrapper around
1994 various command routines in a place where both protocol messages and
1995 user input both flow through. Mostly this is used for indicating whether
1996 the target process is running or not.
2000 gdbtk_call_command (cmdblk
, arg
, from_tty
)
2001 struct cmd_list_element
*cmdblk
;
2006 if (cmdblk
->class == class_run
|| cmdblk
->class == class_trace
)
2009 /* HACK! HACK! This is to get the gui to update the tstart/tstop
2010 button only incase of tstart/tstop commands issued from the console
2011 We don't want to update the src window, s we need to have specific
2012 procedures to do tstart and tstop
2014 if (!strcmp(cmdblk
->name
, "tstart") && !No_Update
)
2015 Tcl_Eval (interp
, "gdbtk_tcl_tstart");
2016 else if (!strcmp(cmdblk
->name
, "tstop") && !No_Update
)
2017 Tcl_Eval (interp
, "gdbtk_tcl_tstop");
2023 Tcl_Eval (interp
, "gdbtk_tcl_busy");
2024 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
2027 Tcl_Eval (interp
, "gdbtk_tcl_idle");
2031 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
2034 /* This function is called instead of gdb's internal command loop. This is the
2035 last chance to do anything before entering the main Tk event loop. */
2040 extern GDB_FILE
*instream
;
2042 /* We no longer want to use stdin as the command input stream */
2045 if (Tcl_Eval (interp
, "gdbtk_tcl_preloop") != TCL_OK
)
2049 /* Force errorInfo to be set up propertly. */
2050 Tcl_AddErrorInfo (interp
, "");
2052 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
2054 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
2056 fputs_unfiltered (msg
, gdb_stderr
);
2067 /* gdbtk_init installs this function as a final cleanup. */
2070 gdbtk_cleanup (dummy
)
2074 struct ide_event_handle
*h
= (struct ide_event_handle
*) dummy
;
2076 ide_interface_deregister_all (h
);
2081 /* Initialize gdbtk. */
2084 gdbtk_init ( argv0
)
2087 struct cleanup
*old_chain
;
2088 char *lib
, *gdbtk_lib
, *gdbtk_lib_tmp
, *gdbtk_file
;
2091 struct sigaction action
;
2092 static sigset_t nullsigmask
= {0};
2095 /* start-sanitize-ide */
2096 struct ide_event_handle
*h
;
2099 /* end-sanitize-ide */
2102 /* If there is no DISPLAY environment variable, Tk_Init below will fail,
2103 causing gdb to abort. If instead we simply return here, gdb will
2104 gracefully degrade to using the command line interface. */
2107 if (getenv ("DISPLAY") == NULL
)
2111 old_chain
= make_cleanup (cleanup_init
, 0);
2113 /* First init tcl and tk. */
2114 Tcl_FindExecutable (argv0
);
2115 interp
= Tcl_CreateInterp ();
2117 #ifdef TCL_MEM_DEBUG
2118 Tcl_InitMemory (interp
);
2122 error ("Tcl_CreateInterp failed");
2124 if (Tcl_Init(interp
) != TCL_OK
)
2125 error ("Tcl_Init failed: %s", interp
->result
);
2128 /* For the IDE we register the cleanup later, after we've
2129 initialized events. */
2130 make_final_cleanup (gdbtk_cleanup
, NULL
);
2133 /* Initialize the Paths variable. */
2134 if (ide_initialize_paths (interp
, "gdbtcl") != TCL_OK
)
2135 error ("ide_initialize_paths failed: %s", interp
->result
);
2138 /* start-sanitize-ide */
2139 /* Find the directory where we expect to find idemanager. We ignore
2140 errors since it doesn't really matter if this fails. */
2141 libexecdir
= Tcl_GetVar2 (interp
, "Paths", "libexecdir", TCL_GLOBAL_ONLY
);
2145 h
= ide_event_init_from_environment (&errmsg
, libexecdir
);
2146 make_final_cleanup (gdbtk_cleanup
, h
);
2149 Tcl_AppendResult (interp
, "can't initialize event system: ", errmsg
,
2151 fprintf(stderr
, "WARNING: ide_event_init_client failed: %s\n", interp
->result
);
2153 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
2157 if (ide_create_tclevent_command (interp
, h
) != TCL_OK
)
2158 error ("ide_create_tclevent_command failed: %s", interp
->result
);
2160 if (ide_create_edit_command (interp
, h
) != TCL_OK
)
2161 error ("ide_create_edit_command failed: %s", interp
->result
);
2163 if (ide_create_property_command (interp
, h
) != TCL_OK
)
2164 error ("ide_create_property_command failed: %s", interp
->result
);
2166 if (ide_create_build_command (interp
, h
) != TCL_OK
)
2167 error ("ide_create_build_command failed: %s", interp
->result
);
2169 if (ide_create_window_register_command (interp
, h
, "gdb-restore")
2171 error ("ide_create_window_register_command failed: %s",
2174 if (ide_create_window_command (interp
, h
) != TCL_OK
)
2175 error ("ide_create_window_command failed: %s", interp
->result
);
2177 if (ide_create_exit_command (interp
, h
) != TCL_OK
)
2178 error ("ide_create_exit_command failed: %s", interp
->result
);
2180 if (ide_create_help_command (interp
) != TCL_OK
)
2181 error ("ide_create_help_command failed: %s", interp
->result
);
2184 if (ide_initialize (interp, "gdb") != TCL_OK)
2185 error ("ide_initialize failed: %s", interp->result);
2188 Tcl_SetVar (interp
, "GDBTK_IDE", "1", 0);
2190 /* end-sanitize-ide */
2192 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
2195 /* We don't want to open the X connection until we've done all the
2196 IDE initialization. Otherwise, goofy looking unfinished windows
2197 pop up when ILU drops into the TCL event loop. */
2199 if (Tk_Init(interp
) != TCL_OK
)
2200 error ("Tk_Init failed: %s", interp
->result
);
2202 if (Itcl_Init(interp
) == TCL_ERROR
)
2203 error ("Itcl_Init failed: %s", interp
->result
);
2205 if (Tix_Init(interp
) != TCL_OK
)
2206 error ("Tix_Init failed: %s", interp
->result
);
2209 if (ide_create_messagebox_command (interp
) != TCL_OK
)
2210 error ("messagebox command initialization failed");
2211 /* On Windows, create a sizebox widget command */
2212 if (ide_create_sizebox_command (interp
) != TCL_OK
)
2213 error ("sizebox creation failed");
2214 if (ide_create_winprint_command (interp
) != TCL_OK
)
2215 error ("windows print code initialization failed");
2216 /* start-sanitize-ide */
2217 /* An interface to ShellExecute. */
2218 if (ide_create_shell_execute_command (interp
) != TCL_OK
)
2219 error ("shell execute command initialization failed");
2220 /* end-sanitize-ide */
2221 if (ide_create_win_grab_command (interp
) != TCL_OK
)
2222 error ("grab support command initialization failed");
2223 /* Path conversion functions. */
2224 if (ide_create_cygwin_path_command (interp
) != TCL_OK
)
2225 error ("cygwin path command initialization failed");
2228 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
2229 Tcl_CreateCommand (interp
, "gdb_immediate", call_wrapper
,
2230 gdb_immediate_command
, NULL
);
2231 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
2232 Tcl_CreateCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
2233 Tcl_CreateObjCommand (interp
, "gdb_listfiles", call_obj_wrapper
, gdb_listfiles
, NULL
);
2234 Tcl_CreateCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
2236 Tcl_CreateCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
2238 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
2239 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
2240 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
2241 gdb_fetch_registers
, NULL
);
2242 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
2243 gdb_changed_register_list
, NULL
);
2244 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
2245 gdb_disassemble
, NULL
);
2246 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
2247 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
2248 gdb_get_breakpoint_list
, NULL
);
2249 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
2250 gdb_get_breakpoint_info
, NULL
);
2251 Tcl_CreateCommand (interp
, "gdb_clear_file", call_wrapper
,
2252 gdb_clear_file
, NULL
);
2253 Tcl_CreateCommand (interp
, "gdb_confirm_quit", call_wrapper
,
2254 gdb_confirm_quit
, NULL
);
2255 Tcl_CreateCommand (interp
, "gdb_force_quit", call_wrapper
,
2256 gdb_force_quit
, NULL
);
2257 Tcl_CreateCommand (interp
, "gdb_target_has_execution",
2258 gdb_target_has_execution_command
,
2260 Tcl_CreateCommand (interp
, "gdb_is_tracing",
2263 Tcl_CreateObjCommand (interp
, "gdb_load_info", call_obj_wrapper
, gdb_load_info
, NULL
);
2264 Tcl_CreateObjCommand (interp
, "gdb_get_locals", call_obj_wrapper
, gdb_get_vars_command
,
2266 Tcl_CreateObjCommand (interp
, "gdb_get_args", call_obj_wrapper
, gdb_get_vars_command
,
2268 Tcl_CreateObjCommand (interp
, "gdb_get_function", call_obj_wrapper
, gdb_get_function_command
,
2270 Tcl_CreateObjCommand (interp
, "gdb_get_line", call_obj_wrapper
, gdb_get_line_command
,
2272 Tcl_CreateObjCommand (interp
, "gdb_get_file", call_obj_wrapper
, gdb_get_file_command
,
2274 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
2275 call_obj_wrapper
, gdb_tracepoint_exists_command
, NULL
);
2276 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
2277 call_obj_wrapper
, gdb_get_tracepoint_info
, NULL
);
2278 Tcl_CreateObjCommand (interp
, "gdb_actions",
2279 call_obj_wrapper
, gdb_actions_command
, NULL
);
2280 Tcl_CreateObjCommand (interp
, "gdb_prompt",
2281 call_obj_wrapper
, gdb_prompt_command
, NULL
);
2282 Tcl_CreateObjCommand (interp
, "gdb_find_file",
2283 call_obj_wrapper
, gdb_find_file_command
, NULL
);
2284 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
2285 call_obj_wrapper
, gdb_get_tracepoint_list
, NULL
);
2286 Tcl_CreateCommand (interp
, "gdb_pc_reg", get_pc_register
, NULL
, NULL
);
2287 Tcl_CreateObjCommand (interp
, "gdb_loadfile", call_obj_wrapper
, gdb_loadfile
, NULL
);
2288 Tcl_CreateObjCommand (interp
, "gdb_set_bp", call_obj_wrapper
, gdb_set_bp
, NULL
);
2290 command_loop_hook
= tk_command_loop
;
2291 print_frame_info_listing_hook
= gdbtk_print_frame_info
;
2292 query_hook
= gdbtk_query
;
2293 warning_hook
= gdbtk_warning
;
2294 flush_hook
= gdbtk_flush
;
2295 create_breakpoint_hook
= gdbtk_create_breakpoint
;
2296 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
2297 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
2298 interactive_hook
= gdbtk_interactive
;
2299 target_wait_hook
= gdbtk_wait
;
2300 call_command_hook
= gdbtk_call_command
;
2301 readline_begin_hook
= gdbtk_readline_begin
;
2302 readline_hook
= gdbtk_readline
;
2303 readline_end_hook
= gdbtk_readline_end
;
2304 ui_load_progress_hook
= gdbtk_load_hash
;
2305 pre_add_symbol_hook
= gdbtk_pre_add_symbol
;
2306 post_add_symbol_hook
= gdbtk_post_add_symbol
;
2307 create_tracepoint_hook
= gdbtk_create_tracepoint
;
2308 delete_tracepoint_hook
= gdbtk_delete_tracepoint
;
2309 modify_tracepoint_hook
= gdbtk_modify_tracepoint
;
2310 pc_changed_hook
= pc_changed
;
2312 add_com ("tk", class_obscure
, tk_command
,
2313 "Send a command directly into tk.");
2315 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
2318 /* find the gdb tcl library and source main.tcl */
2320 gdbtk_lib
= getenv ("GDBTK_LIBRARY");
2322 if (access ("gdbtcl/main.tcl", R_OK
) == 0)
2323 gdbtk_lib
= "gdbtcl";
2325 gdbtk_lib
= GDBTK_LIBRARY
;
2327 gdbtk_lib_tmp
= xstrdup (gdbtk_lib
);
2330 /* see if GDBTK_LIBRARY is a path list */
2331 lib
= strtok (gdbtk_lib_tmp
, GDBTK_PATH_SEP
);
2334 if (Tcl_VarEval (interp
, "lappend auto_path ", lib
, NULL
) != TCL_OK
)
2336 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2341 gdbtk_file
= concat (lib
, "/main.tcl", (char *) NULL
);
2342 if (access (gdbtk_file
, R_OK
) == 0)
2345 Tcl_SetVar (interp
, "GDBTK_LIBRARY", lib
, 0);
2349 while ((lib
= strtok (NULL
, ":")) != NULL
);
2351 free (gdbtk_lib_tmp
);
2355 /* Try finding it with the auto path. */
2357 static const char script
[] ="\
2358 proc gdbtk_find_main {} {\n\
2359 global auto_path GDBTK_LIBRARY\n\
2360 foreach dir $auto_path {\n\
2361 set f [file join $dir main.tcl]\n\
2362 if {[file exists $f]} then {\n\
2363 set GDBTK_LIBRARY $dir\n\
2371 if (Tcl_GlobalEval (interp
, (char *) script
) != TCL_OK
)
2373 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2377 if (interp
->result
[0] != '\0')
2379 gdbtk_file
= xstrdup (interp
->result
);
2386 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2387 if (getenv("GDBTK_LIBRARY"))
2389 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
2390 fprintf_unfiltered (stderr
,
2391 "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
2395 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY
);
2396 fprintf_unfiltered (stderr
, "You might want to set GDBTK_LIBRARY\n");
2401 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
2402 prior to this point go to stdout/stderr. */
2404 fputs_unfiltered_hook
= gdbtk_fputs
;
2406 if (Tcl_EvalFile (interp
, gdbtk_file
) != TCL_OK
)
2410 /* Force errorInfo to be set up propertly. */
2411 Tcl_AddErrorInfo (interp
, "");
2413 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
2415 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2418 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
2420 fputs_unfiltered (msg
, gdb_stderr
);
2427 /* start-sanitize-ide */
2428 /* Don't do this until we have initialized. Otherwise, we may get a
2429 run command before we are ready for one. */
2430 if (ide_run_server_init (interp
, h
) != TCL_OK
)
2431 error ("ide_run_server_init failed: %s", interp
->result
);
2432 /* end-sanitize-ide */
2437 discard_cleanups (old_chain
);
2441 gdb_target_has_execution_command (clientData
, interp
, argc
, argv
)
2442 ClientData clientData
;
2449 if (target_has_execution
&& inferior_pid
!= 0)
2452 Tcl_SetIntObj (Tcl_GetObjResult (interp
), result
);
2457 gdb_trace_status (clientData
, interp
, argc
, argv
)
2458 ClientData clientData
;
2465 if (trace_running_p
)
2468 Tcl_SetIntObj (Tcl_GetObjResult (interp
), result
);
2472 /* gdb_load_info - returns information about the file about to be downloaded */
2475 gdb_load_info (clientData
, interp
, objc
, objv
)
2476 ClientData clientData
;
2479 Tcl_Obj
*CONST objv
[];
2482 struct cleanup
*old_cleanups
;
2488 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
2490 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
2491 if (loadfile_bfd
== NULL
)
2493 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Open failed", -1));
2496 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
2498 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
2500 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Bad Object File", -1));
2504 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
2506 if (s
->flags
& SEC_LOAD
)
2508 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
2511 ob
[0] = Tcl_NewStringObj((char *)bfd_get_section_name(loadfile_bfd
, s
), -1);
2512 ob
[1] = Tcl_NewLongObj ((long)size
);
2513 res
[i
++] = Tcl_NewListObj (2, ob
);
2518 Tcl_SetObjResult (interp
, Tcl_NewListObj (i
, res
));
2519 do_cleanups (old_cleanups
);
2525 gdbtk_load_hash (section
, num
)
2530 sprintf (buf
, "download_hash %s %ld", section
, num
);
2531 Tcl_Eval (interp
, buf
);
2532 return atoi (interp
->result
);
2536 * This and gdb_get_locals just call gdb_get_vars_command with the right
2537 * value of clientData. We can't use the client data in the definition
2538 * of the command, because the call wrapper uses this instead...
2542 gdb_get_locals (clientData
, interp
, objc
, objv
)
2543 ClientData clientData
;
2546 Tcl_Obj
*CONST objv
[];
2549 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
2554 gdb_get_args (clientData
, interp
, objc
, objv
)
2555 ClientData clientData
;
2558 Tcl_Obj
*CONST objv
[];
2561 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
2565 /* gdb_get_vars_command -
2567 * Implements the "gdb_get_locals" and "gdb_get_args" tcl commands. This
2568 * function sets the Tcl interpreter's result to a list of variable names
2569 * depending on clientData. If clientData is one, the result is a list of
2570 * arguments; zero returns a list of locals -- all relative to the block
2571 * specified as an argument to the command. Valid commands include
2572 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
2576 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
2577 ClientData clientData
;
2580 Tcl_Obj
*CONST objv
[];
2583 struct symtabs_and_lines sals
;
2585 struct block
*block
;
2586 char **canonical
, *args
;
2587 int i
, nsyms
, arguments
;
2591 Tcl_AppendResult (interp
,
2592 "wrong # of args: should be \"",
2593 Tcl_GetStringFromObj (objv
[0], NULL
),
2594 " function:line|function|line|*addr\"");
2598 arguments
= (int) clientData
;
2599 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2600 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2601 if (sals
.nelts
== 0)
2603 Tcl_AppendResult (interp
,
2604 "error decoding line", NULL
);
2608 /* Initialize a list that will hold the results */
2609 result
= Tcl_NewListObj (0, NULL
);
2611 /* Resolve all line numbers to PC's */
2612 for (i
= 0; i
< sals
.nelts
; i
++)
2613 resolve_sal_pc (&sals
.sals
[i
]);
2615 block
= block_for_pc (sals
.sals
[0].pc
);
2618 nsyms
= BLOCK_NSYMS (block
);
2619 for (i
= 0; i
< nsyms
; i
++)
2621 sym
= BLOCK_SYM (block
, i
);
2622 switch (SYMBOL_CLASS (sym
)) {
2624 case LOC_UNDEF
: /* catches errors */
2625 case LOC_CONST
: /* constant */
2626 case LOC_STATIC
: /* static */
2627 case LOC_REGISTER
: /* register */
2628 case LOC_TYPEDEF
: /* local typedef */
2629 case LOC_LABEL
: /* local label */
2630 case LOC_BLOCK
: /* local function */
2631 case LOC_CONST_BYTES
: /* loc. byte seq. */
2632 case LOC_UNRESOLVED
: /* unresolved static */
2633 case LOC_OPTIMIZED_OUT
: /* optimized out */
2635 case LOC_ARG
: /* argument */
2636 case LOC_REF_ARG
: /* reference arg */
2637 case LOC_REGPARM
: /* register arg */
2638 case LOC_REGPARM_ADDR
: /* indirect register arg */
2639 case LOC_LOCAL_ARG
: /* stack arg */
2640 case LOC_BASEREG_ARG
: /* basereg arg */
2642 Tcl_ListObjAppendElement (interp
, result
,
2643 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2645 case LOC_LOCAL
: /* stack local */
2646 case LOC_BASEREG
: /* basereg local */
2648 Tcl_ListObjAppendElement (interp
, result
,
2649 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2653 if (BLOCK_FUNCTION (block
))
2656 block
= BLOCK_SUPERBLOCK (block
);
2659 Tcl_SetObjResult (interp
, result
);
2664 gdb_get_line_command (clientData
, interp
, objc
, objv
)
2665 ClientData clientData
;
2668 Tcl_Obj
*CONST objv
[];
2671 struct symtabs_and_lines sals
;
2672 char *args
, **canonical
;
2676 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2677 Tcl_GetStringFromObj (objv
[0], NULL
),
2682 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2683 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2684 if (sals
.nelts
== 1)
2686 Tcl_SetObjResult (interp
, Tcl_NewIntObj (sals
.sals
[0].line
));
2690 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2695 gdb_get_file_command (clientData
, interp
, objc
, objv
)
2696 ClientData clientData
;
2699 Tcl_Obj
*CONST objv
[];
2702 struct symtabs_and_lines sals
;
2703 char *args
, **canonical
;
2707 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2708 Tcl_GetStringFromObj (objv
[0], NULL
),
2713 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2714 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2715 if (sals
.nelts
== 1)
2717 Tcl_SetResult (interp
, sals
.sals
[0].symtab
->filename
, TCL_VOLATILE
);
2721 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2726 gdb_get_function_command (clientData
, interp
, objc
, objv
)
2727 ClientData clientData
;
2730 Tcl_Obj
*CONST objv
[];
2734 struct symtabs_and_lines sals
;
2735 char *args
, **canonical
;
2739 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2740 Tcl_GetStringFromObj (objv
[0], NULL
),
2745 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2746 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2747 if (sals
.nelts
== 1)
2749 resolve_sal_pc (&sals
.sals
[0]);
2750 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
2751 if (function
!= NULL
)
2753 Tcl_SetResult (interp
, function
, TCL_VOLATILE
);
2758 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2763 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
2764 ClientData clientData
;
2767 Tcl_Obj
*CONST objv
[];
2769 struct symtab_and_line sal
;
2771 struct tracepoint
*tp
;
2772 struct action_line
*al
;
2773 Tcl_Obj
*list
, *action_list
;
2774 char *filename
, *funcname
;
2778 error ("wrong # args");
2780 Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
);
2782 ALL_TRACEPOINTS (tp
)
2783 if (tp
->number
== tpnum
)
2787 error ("Tracepoint #%d does not exist", tpnum
);
2789 list
= Tcl_NewListObj (0, NULL
);
2790 sal
= find_pc_line (tp
->address
, 0);
2791 filename
= symtab_to_filename (sal
.symtab
);
2792 if (filename
== NULL
)
2794 Tcl_ListObjAppendElement (interp
, list
,
2795 Tcl_NewStringObj (filename
, -1));
2796 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
2797 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (funcname
, -1));
2798 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (sal
.line
));
2799 sprintf (tmp
, "0x%lx", tp
->address
);
2800 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (tmp
, -1));
2801 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->enabled
));
2802 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->pass_count
));
2803 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->step_count
));
2804 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->thread
));
2805 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->hit_count
));
2807 /* Append a list of actions */
2808 action_list
= Tcl_NewListObj (0, NULL
);
2809 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
2811 Tcl_ListObjAppendElement (interp
, action_list
,
2812 Tcl_NewStringObj (al
->action
, -1));
2814 Tcl_ListObjAppendElement (interp
, list
, action_list
);
2816 Tcl_SetObjResult (interp
, list
);
2821 /* TclDebug (const char *fmt, ...) works just like printf() but */
2822 /* sends the output to the GDB TK debug window. */
2823 /* Not for normal use; just a convenient tool for debugging */
2825 #ifdef ANSI_PROTOTYPES
2826 TclDebug (const char *fmt
, ...)
2833 char buf
[512], *v
[2], *merge
;
2835 #ifdef ANSI_PROTOTYPES
2836 va_start (args
, fmt
);
2840 fmt
= va_arg (args
, char *);
2846 vsprintf (buf
, fmt
, args
);
2849 merge
= Tcl_Merge (2, v
);
2850 Tcl_Eval (interp
, merge
);
2855 /* Find the full pathname to a file, searching the symbol tables */
2858 gdb_find_file_command (clientData
, interp
, objc
, objv
)
2859 ClientData clientData
;
2862 Tcl_Obj
*CONST objv
[];
2864 char *filename
= NULL
;
2869 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
2873 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
2875 filename
= st
->fullname
;
2877 if (filename
== NULL
)
2878 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("", 0));
2880 Tcl_SetObjResult (interp
, Tcl_NewStringObj (filename
, -1));
2886 gdbtk_create_tracepoint (tp
)
2887 struct tracepoint
*tp
;
2889 tracepoint_notify (tp
, "create");
2893 gdbtk_delete_tracepoint (tp
)
2894 struct tracepoint
*tp
;
2896 tracepoint_notify (tp
, "delete");
2900 gdbtk_modify_tracepoint (tp
)
2901 struct tracepoint
*tp
;
2903 tracepoint_notify (tp
, "modify");
2907 tracepoint_notify(tp
, action
)
2908 struct tracepoint
*tp
;
2913 struct symtab_and_line sal
;
2916 /* We ensure that ACTION contains no special Tcl characters, so we
2918 sal
= find_pc_line (tp
->address
, 0);
2920 filename
= symtab_to_filename (sal
.symtab
);
2921 if (filename
== NULL
)
2923 sprintf (buf
, "gdbtk_tcl_tracepoint %s %d 0x%lx %d {%s}", action
, tp
->number
,
2924 (long)tp
->address
, sal
.line
, filename
, tp
->pass_count
);
2926 v
= Tcl_Eval (interp
, buf
);
2930 gdbtk_fputs (interp
->result
, gdb_stdout
);
2931 gdbtk_fputs ("\n", gdb_stdout
);
2935 /* returns -1 if not found, tracepoint # if found */
2937 tracepoint_exists (char * args
)
2939 struct tracepoint
*tp
;
2941 struct symtabs_and_lines sals
;
2945 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2946 if (sals
.nelts
== 1)
2948 resolve_sal_pc (&sals
.sals
[0]);
2949 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
2950 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
2953 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
2954 strcat (file
, sals
.sals
[0].symtab
->filename
);
2956 ALL_TRACEPOINTS (tp
)
2958 if (tp
->address
== sals
.sals
[0].pc
)
2959 result
= tp
->number
;
2961 /* Why is this here? This messes up assembly traces */
2962 else if (tp
->source_file
!= NULL
2963 && strcmp (tp
->source_file
, file
) == 0
2964 && sals
.sals
[0].line
== tp
->line_number
)
2965 result
= tp
->number
;
2976 gdb_actions_command (clientData
, interp
, objc
, objv
)
2977 ClientData clientData
;
2980 Tcl_Obj
*CONST objv
[];
2982 struct tracepoint
*tp
;
2984 int nactions
, i
, len
;
2985 char *number
, *args
, *action
;
2987 struct action_line
*next
= NULL
, *temp
;
2991 Tcl_AppendResult (interp
, "wrong # args: should be: \"",
2992 Tcl_GetStringFromObj (objv
[0], NULL
),
2993 " number actions\"");
2997 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
2998 tp
= get_tracepoint_by_number (&args
);
3001 Tcl_AppendResult (interp
, "Tracepoint \"", number
, "\" does not exist");
3005 /* Free any existing actions */
3006 if (tp
->actions
!= NULL
)
3011 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
3012 for (i
= 0; i
< nactions
; i
++)
3014 temp
= xmalloc (sizeof (struct action_line
));
3016 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
3017 temp
->action
= savestring (action
, len
);
3018 if (sscanf (temp
->action
, "while-stepping %d", &step_count
) !=0)
3019 tp
->step_count
= step_count
;
3036 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
3037 ClientData clientData
;
3040 Tcl_Obj
*CONST objv
[];
3046 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
3047 Tcl_GetStringFromObj (objv
[0], NULL
),
3048 " function:line|function|line|*addr\"");
3052 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
3054 Tcl_SetObjResult (interp
, Tcl_NewIntObj (tracepoint_exists (args
)));
3058 /* Return the prompt to the interpreter */
3060 gdb_prompt_command (clientData
, interp
, objc
, objv
)
3061 ClientData clientData
;
3064 Tcl_Obj
*CONST objv
[];
3066 Tcl_SetResult (interp
, get_prompt (), TCL_VOLATILE
);
3070 /* return a list of all tracepoint numbers in interpreter */
3072 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
3073 ClientData clientData
;
3076 Tcl_Obj
*CONST objv
[];
3079 struct tracepoint
*tp
;
3081 list
= Tcl_NewListObj (0, NULL
);
3083 ALL_TRACEPOINTS (tp
)
3084 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->number
));
3086 Tcl_SetObjResult (interp
, list
);
3091 /* This hook is called whenever we are ready to load a symbol file so that
3092 the UI can notify the user... */
3094 gdbtk_pre_add_symbol (name
)
3099 v
[0] = "gdbtk_tcl_pre_add_symbol";
3101 merge
= Tcl_Merge (2, v
);
3102 Tcl_Eval (interp
, merge
);
3106 /* This hook is called whenever we finish loading a symbol file. */
3108 gdbtk_post_add_symbol ()
3110 Tcl_Eval (interp
, "gdbtk_tcl_post_add_symbol");
3116 gdbtk_print_frame_info (s
, line
, stopline
, noerror
)
3122 current_source_symtab
= s
;
3123 current_source_line
= line
;
3127 /* The lookup_symtab() in symtab.c doesn't work correctly */
3128 /* It will not work will full pathnames and if multiple */
3129 /* source files have the same basename, it will return */
3130 /* the first one instead of the correct one. This version */
3131 /* also always makes sure symtab->fullname is set. */
3133 static struct symtab
*
3134 full_lookup_symtab(file
)
3138 struct objfile
*objfile
;
3139 char *bfile
, *fullname
;
3140 struct partial_symtab
*pt
;
3145 /* first try a direct lookup */
3146 st
= lookup_symtab (file
);
3150 symtab_to_filename(st
);
3154 /* if the direct approach failed, try */
3155 /* looking up the basename and checking */
3156 /* all matches with the fullname */
3157 bfile
= basename (file
);
3158 ALL_SYMTABS (objfile
, st
)
3160 if (!strcmp (bfile
, basename(st
->filename
)))
3163 fullname
= symtab_to_filename (st
);
3165 fullname
= st
->fullname
;
3167 if (!strcmp (file
, fullname
))
3172 /* still no luck? look at psymtabs */
3173 ALL_PSYMTABS (objfile
, pt
)
3175 if (!strcmp (bfile
, basename(pt
->filename
)))
3177 st
= PSYMTAB_TO_SYMTAB (pt
);
3180 fullname
= symtab_to_filename (st
);
3181 if (!strcmp (file
, fullname
))
3190 perror_with_name_wrapper (args
)
3193 perror_with_name (args
);
3197 /* gdb_loadfile loads a c source file into a text widget. */
3199 /* LTABLE_SIZE is the number of bytes to allocate for the */
3200 /* line table. Its size limits the maximum number of lines */
3201 /* in a file to 8 * LTABLE_SIZE. This memory is freed after */
3202 /* the file is loaded, so it is OK to make this very large. */
3203 /* Additional memory will be allocated if needed. */
3204 #define LTABLE_SIZE 20000
3207 gdb_loadfile (clientData
, interp
, objc
, objv
)
3208 ClientData clientData
;
3211 Tcl_Obj
*CONST objv
[];
3213 char *file
, *widget
, *line
, *buf
, msg
[128];
3214 int linenumbers
, ln
, anum
, lnum
, ltable_size
;
3215 Tcl_Obj
*a
[2], *b
[2], *cmd
;
3218 struct symtab
*symtab
;
3219 struct linetable_entry
*le
;
3226 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
3230 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
3231 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
3232 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
3234 if ((fp
= fopen ( file
, "r" )) == NULL
)
3237 symtab
= full_lookup_symtab (file
);
3240 sprintf(msg
, "File not found");
3241 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3246 if (stat (file
, &st
) < 0)
3248 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
3253 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
3254 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
3256 mtime
= bfd_get_mtime(exec_bfd
);
3258 if (mtime
&& mtime
< st
.st_mtime
)
3259 gdbtk_ignorable_warning("Source file is more recent than executable.\n", (va_list)0);
3262 /* Source linenumbers don't appear to be in order, and a sort is */
3263 /* too slow so the fastest solution is just to allocate a huge */
3264 /* array and set the array entry for each linenumber */
3266 ltable_size
= LTABLE_SIZE
;
3267 ltable
= (char *)malloc (LTABLE_SIZE
);
3270 sprintf(msg
, "Out of memory.");
3271 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3276 memset (ltable
, 0, LTABLE_SIZE
);
3278 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
3280 le
= symtab
->linetable
->item
;
3281 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
3283 lnum
= le
->line
>> 3;
3284 if (lnum
>= ltable_size
)
3287 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
3288 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
3290 if (new_ltable
== NULL
)
3292 sprintf(msg
, "Out of memory.");
3293 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3298 ltable
= new_ltable
;
3300 ltable
[lnum
] |= 1 << (le
->line
% 8);
3304 /* create an object with enough space, then grab its */
3305 /* buffer and sprintf directly into it. */
3306 a
[0] = Tcl_NewStringObj (ltable
, 1024);
3307 a
[1] = Tcl_NewListObj(0,NULL
);
3309 b
[0] = Tcl_NewStringObj (ltable
,1024);
3310 b
[1] = Tcl_NewStringObj ("source_tag", -1);
3311 Tcl_IncrRefCount (b
[0]);
3312 Tcl_IncrRefCount (b
[1]);
3313 line
= b
[0]->bytes
+ 1;
3314 strcpy(b
[0]->bytes
,"\t");
3317 while (fgets (line
, 980, fp
))
3321 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3323 sprintf (buf
,"%s insert end {-\t%d} break_tag", widget
, ln
);
3324 a
[0]->length
= strlen (buf
);
3328 sprintf (buf
,"%s insert end { \t%d} \"\"", widget
, ln
);
3329 a
[0]->length
= strlen (buf
);
3334 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3336 sprintf (buf
,"%s insert end {-\t} break_tag", widget
);
3337 a
[0]->length
= strlen (buf
);
3341 sprintf (buf
,"%s insert end { \t} \"\"", widget
);
3342 a
[0]->length
= strlen (buf
);
3345 b
[0]->length
= strlen(b
[0]->bytes
);
3346 Tcl_SetListObj(a
[1],2,b
);
3347 cmd
= Tcl_ConcatObj(2,a
);
3348 Tcl_EvalObj (interp
, cmd
);
3349 Tcl_DecrRefCount (cmd
);
3352 Tcl_DecrRefCount (b
[0]);
3353 Tcl_DecrRefCount (b
[0]);
3354 Tcl_DecrRefCount (b
[1]);
3355 Tcl_DecrRefCount (b
[1]);
3361 /* at some point make these static in breakpoint.c and move GUI code there */
3362 extern struct breakpoint
*set_raw_breakpoint (struct symtab_and_line sal
);
3363 extern void set_breakpoint_count (int);
3364 extern int breakpoint_count
;
3366 /* set a breakpoint by source file and line number */
3367 /* flags are as follows: */
3368 /* least significant 2 bits are disposition, rest is */
3369 /* type (normally 0).
3372 bp_breakpoint, Normal breakpoint
3373 bp_hardware_breakpoint, Hardware assisted breakpoint
3376 Disposition of breakpoint. Ie: what to do after hitting it.
3379 del_at_next_stop, Delete at next stop, whether hit or not
3381 donttouch Leave it alone
3386 gdb_set_bp (clientData
, interp
, objc
, objv
)
3387 ClientData clientData
;
3390 Tcl_Obj
*CONST objv
[];
3393 struct symtab_and_line sal
;
3394 int line
, flags
, ret
;
3395 struct breakpoint
*b
;
3397 Tcl_Obj
*a
[5], *cmd
;
3401 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
3405 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
3406 if (sal
.symtab
== NULL
)
3409 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
3412 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
3416 sal
.pc
= find_line_pc (sal
.symtab
, sal
.line
);
3420 sal
.section
= find_pc_overlay (sal
.pc
);
3421 b
= set_raw_breakpoint (sal
);
3422 set_breakpoint_count (breakpoint_count
+ 1);
3423 b
->number
= breakpoint_count
;
3424 b
->type
= flags
>> 2;
3425 b
->disposition
= flags
& 3;
3427 /* FIXME: this won't work for duplicate basenames! */
3428 sprintf (buf
, "%s:%d", basename(Tcl_GetStringFromObj( objv
[1], NULL
)), line
);
3429 b
->addr_string
= strsave (buf
);
3431 /* now send notification command back to GUI */
3432 sprintf (buf
, "0x%x", sal
.pc
);
3433 a
[0] = Tcl_NewStringObj ("gdbtk_tcl_breakpoint create", -1);
3434 a
[1] = Tcl_NewIntObj (b
->number
);
3435 a
[2] = Tcl_NewStringObj (buf
, -1);
3437 a
[4] = Tcl_NewListObj (1,&objv
[1]);
3438 cmd
= Tcl_ConcatObj(5,a
);
3439 ret
= Tcl_EvalObj (interp
, cmd
);
3440 Tcl_DecrRefCount (cmd
);
3444 /* Come here during initialize_all_files () */
3447 _initialize_gdbtk ()
3451 /* Tell the rest of the world that Gdbtk is now set up. */
3453 init_ui_hook
= gdbtk_init
;