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 load_in_progress
= 0;
92 static int in_fputs
= 0;
94 int gdbtk_load_hash
PARAMS ((char *, unsigned long));
95 int (*ui_load_progress_hook
) PARAMS ((char *, unsigned long));
96 void (*pre_add_symbol_hook
) PARAMS ((char *));
97 void (*post_add_symbol_hook
) PARAMS ((void));
99 /* This is a disgusting hack. Unfortunately, the UI will lock up if we
100 are doing something like blocking in a system call, waiting for serial I/O,
103 This hook should be used whenever we might block. This means adding appropriate
104 timeouts to code and what not to allow this hook to be called. */
105 void (*ui_loop_hook
) PARAMS ((int));
107 char * get_prompt
PARAMS ((void));
109 static void null_routine
PARAMS ((int));
110 static void gdbtk_flush
PARAMS ((FILE *));
111 static void gdbtk_fputs
PARAMS ((const char *, FILE *));
112 static int gdbtk_query
PARAMS ((const char *, va_list));
113 static char *gdbtk_readline
PARAMS ((char *));
114 static void gdbtk_init
PARAMS ((char *));
115 static void tk_command_loop
PARAMS ((void));
116 static void gdbtk_call_command
PARAMS ((struct cmd_list_element
*, char *, int));
117 static int gdbtk_wait
PARAMS ((int, struct target_waitstatus
*));
118 static void x_event
PARAMS ((int));
119 static void gdbtk_interactive
PARAMS ((void));
120 static void cleanup_init
PARAMS ((int));
121 static void tk_command
PARAMS ((char *, int));
122 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
123 static int compare_lines
PARAMS ((const PTR
, const PTR
));
124 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
125 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
126 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
127 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
128 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
129 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
130 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
131 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
132 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
133 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
134 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
135 static void gdbtk_readline_end
PARAMS ((void));
136 static void pc_changed
PARAMS ((void));
137 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
138 static void register_changed_p
PARAMS ((int, void *));
139 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
140 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
141 static void breakpoint_notify
PARAMS ((struct breakpoint
*, const char *));
142 static void gdbtk_create_breakpoint
PARAMS ((struct breakpoint
*));
143 static void gdbtk_delete_breakpoint
PARAMS ((struct breakpoint
*));
144 static void gdbtk_modify_breakpoint
PARAMS ((struct breakpoint
*));
145 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
146 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
147 static int map_arg_registers
PARAMS ((int, char *[], void (*) (int, void *), void *));
148 static void get_register_name
PARAMS ((int, void *));
149 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
150 static void get_register
PARAMS ((int, void *));
151 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
152 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
153 void TclDebug
PARAMS ((const char *fmt
, ...));
154 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
155 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
156 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
157 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
158 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
159 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
160 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
161 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
162 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
163 static char *find_file_in_dir
PARAMS ((char *));
164 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
165 static void gdbtk_create_tracepoint
PARAMS ((struct tracepoint
*));
166 static void gdbtk_delete_tracepoint
PARAMS ((struct tracepoint
*));
167 static void gdbtk_modify_tracepoint
PARAMS ((struct tracepoint
*));
168 static void tracepoint_notify
PARAMS ((struct tracepoint
*, const char *));
169 static void gdbtk_print_frame_info
PARAMS ((struct symtab
*, int, int, int));
170 void gdbtk_pre_add_symbol
PARAMS ((char *));
171 void gdbtk_post_add_symbol
PARAMS ((void));
172 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
173 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
174 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
175 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
176 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
178 static void gdbtk_annotate_starting
PARAMS ((void));
179 static void gdbtk_annotate_stopped
PARAMS ((void));
180 static void gdbtk_annotate_signalled
PARAMS ((void));
181 static void gdbtk_annotate_exited
PARAMS ((void));
184 /* Handle for TCL interpreter */
185 static Tcl_Interp
*interp
= NULL
;
188 static int x_fd
; /* X network socket */
193 /* On Windows we use timer interrupts when gdb might otherwise hang
194 for a long time. See the comment above gdbtk_start_timer. This
195 variable is true when timer interrupts are being used. */
197 static int gdbtk_timer_going
= 0;
199 static void gdbtk_start_timer
PARAMS ((void));
200 static void gdbtk_stop_timer
PARAMS ((void));
204 /* This variable is true when the inferior is running. Although it's
205 possible to disable most input from widgets and thus prevent
206 attempts to do anything while the inferior is running, any commands
207 that get through - even a simple memory read - are Very Bad, and
208 may cause GDB to crash or behave strangely. So, this variable
209 provides an extra layer of defense. */
211 static int running_now
;
213 /* This variable determines where memory used for disassembly is read from.
214 If > 0, then disassembly comes from the exec file rather than the
215 target (which might be at the other end of a slow serial link). If
216 == 0 then disassembly comes from target. If < 0 disassembly is
217 automatically switched to the target if it's an inferior process,
218 otherwise the exec file is used. */
220 static int disassemble_from_exec
= -1;
224 /* Supply malloc calls for tcl/tk. We do not want to do this on
225 Windows, because Tcl_Alloc is probably in a DLL which will not call
226 the mmalloc routines. */
232 return xmalloc (size
);
236 Tcl_Realloc (ptr
, size
)
240 return xrealloc (ptr
, size
);
250 #endif /* ! _WIN32 */
260 /* On Windows, if we hold a file open, other programs can't write to
261 it. In particular, we don't want to hold the executable open,
262 because it will mean that people have to get out of the debugging
263 session in order to remake their program. So we close it, although
264 this will cost us if and when we need to reopen it. */
274 bfd_cache_close (o
->obfd
);
277 if (exec_bfd
!= NULL
)
278 bfd_cache_close (exec_bfd
);
283 /* The following routines deal with stdout/stderr data, which is created by
284 {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the
285 lowest level of these routines and capture all output from the rest of GDB.
286 Normally they present their data to tcl via callbacks to the following tcl
287 routines: gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush. These
288 in turn call tk routines to update the display.
290 Under some circumstances, you may want to collect the output so that it can
291 be returned as the value of a tcl procedure. This can be done by
292 surrounding the output routines with calls to start_saving_output and
293 finish_saving_output. The saved data can then be retrieved with
294 get_saved_output (but this must be done before the call to
295 finish_saving_output). */
297 /* Dynamic string for output. */
299 static Tcl_DString
*result_ptr
;
301 /* Dynamic string for stderr. This is only used if result_ptr is
304 static Tcl_DString
*error_string_ptr
;
311 /* Force immediate screen update */
313 Tcl_VarEval (interp
, "gdbtk_tcl_flush", NULL
);
318 gdbtk_fputs (ptr
, stream
)
322 char *merge
[2], *command
;
326 Tcl_DStringAppend (result_ptr
, (char *) ptr
, -1);
327 else if (error_string_ptr
!= NULL
&& stream
== gdb_stderr
)
328 Tcl_DStringAppend (error_string_ptr
, (char *) ptr
, -1);
331 merge
[0] = "gdbtk_tcl_fputs";
332 merge
[1] = (char *)ptr
;
333 command
= Tcl_Merge (2, merge
);
334 Tcl_Eval (interp
, command
);
341 gdbtk_query (query
, args
)
345 char buf
[200], *merge
[2];
349 vsprintf (buf
, query
, args
);
350 merge
[0] = "gdbtk_tcl_query";
352 command
= Tcl_Merge (2, merge
);
353 Tcl_Eval (interp
, command
);
356 val
= atol (interp
->result
);
362 #ifdef ANSI_PROTOTYPES
363 gdbtk_readline_begin (char *format
, ...)
365 gdbtk_readline_begin (va_alist
)
370 char buf
[200], *merge
[2];
373 #ifdef ANSI_PROTOTYPES
374 va_start (args
, format
);
378 format
= va_arg (args
, char *);
381 vsprintf (buf
, format
, args
);
382 merge
[0] = "gdbtk_tcl_readline_begin";
384 command
= Tcl_Merge (2, merge
);
385 Tcl_Eval (interp
, command
);
390 gdbtk_readline (prompt
)
401 merge
[0] = "gdbtk_tcl_readline";
403 command
= Tcl_Merge (2, merge
);
404 result
= Tcl_Eval (interp
, command
);
406 if (result
== TCL_OK
)
408 return (strdup (interp
-> result
));
412 gdbtk_fputs (interp
-> result
, gdb_stdout
);
413 gdbtk_fputs ("\n", gdb_stdout
);
419 gdbtk_readline_end ()
421 Tcl_Eval (interp
, "gdbtk_tcl_readline_end");
427 Tcl_Eval (interp
, "gdbtk_pc_changed");
432 #ifdef ANSI_PROTOTYPES
433 dsprintf_append_element (Tcl_DString
*dsp
, char *format
, ...)
435 dsprintf_append_element (va_alist
)
442 #ifdef ANSI_PROTOTYPES
443 va_start (args
, format
);
449 dsp
= va_arg (args
, Tcl_DString
*);
450 format
= va_arg (args
, char *);
453 vsprintf (buf
, format
, args
);
455 Tcl_DStringAppendElement (dsp
, buf
);
459 gdb_path_conv (clientData
, interp
, argc
, argv
)
460 ClientData clientData
;
466 char pathname
[256], *ptr
;
468 error ("wrong # args");
469 cygwin32_conv_to_full_win32_path (argv
[1], pathname
);
470 for (ptr
= pathname
; *ptr
; ptr
++)
476 char *pathname
= argv
[1];
478 Tcl_DStringAppend (result_ptr
, pathname
, strlen(pathname
));
483 gdb_get_breakpoint_list (clientData
, interp
, argc
, argv
)
484 ClientData clientData
;
489 struct breakpoint
*b
;
490 extern struct breakpoint
*breakpoint_chain
;
493 error ("wrong # args");
495 for (b
= breakpoint_chain
; b
; b
= b
->next
)
496 if (b
->type
== bp_breakpoint
)
497 dsprintf_append_element (result_ptr
, "%d", b
->number
);
503 gdb_get_breakpoint_info (clientData
, interp
, argc
, argv
)
504 ClientData clientData
;
509 struct symtab_and_line sal
;
510 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
511 "finish", "watchpoint", "hardware watchpoint",
512 "read watchpoint", "access watchpoint",
513 "longjmp", "longjmp resume", "step resume",
514 "through sigtramp", "watchpoint scope",
516 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
517 struct command_line
*cmd
;
519 struct breakpoint
*b
;
520 extern struct breakpoint
*breakpoint_chain
;
521 char *funcname
, *fname
, *filename
;
524 error ("wrong # args");
526 bpnum
= atoi (argv
[1]);
528 for (b
= breakpoint_chain
; b
; b
= b
->next
)
529 if (b
->number
== bpnum
)
532 if (!b
|| b
->type
!= bp_breakpoint
)
533 error ("Breakpoint #%d does not exist", bpnum
);
535 sal
= find_pc_line (b
->address
, 0);
537 filename
= symtab_to_filename (sal
.symtab
);
538 if (filename
== NULL
)
540 Tcl_DStringAppendElement (result_ptr
, filename
);
542 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
543 fname
= cplus_demangle (funcname
, 0);
546 Tcl_DStringAppendElement (result_ptr
, fname
);
550 Tcl_DStringAppendElement (result_ptr
, funcname
);
551 dsprintf_append_element (result_ptr
, "%d", b
->line_number
);
552 dsprintf_append_element (result_ptr
, "0x%lx", b
->address
);
553 Tcl_DStringAppendElement (result_ptr
, bptypes
[b
->type
]);
554 Tcl_DStringAppendElement (result_ptr
, b
->enable
== enabled
? "1" : "0");
555 Tcl_DStringAppendElement (result_ptr
, bpdisp
[b
->disposition
]);
556 dsprintf_append_element (result_ptr
, "%d", b
->ignore_count
);
558 Tcl_DStringStartSublist (result_ptr
);
559 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
560 Tcl_DStringAppendElement (result_ptr
, cmd
->line
);
561 Tcl_DStringEndSublist (result_ptr
);
563 Tcl_DStringAppendElement (result_ptr
, b
->cond_string
);
565 dsprintf_append_element (result_ptr
, "%d", b
->thread
);
566 dsprintf_append_element (result_ptr
, "%d", b
->hit_count
);
572 breakpoint_notify(b
, action
)
573 struct breakpoint
*b
;
578 struct symtab_and_line sal
;
581 if (b
->type
!= bp_breakpoint
)
584 /* We ensure that ACTION contains no special Tcl characters, so we
586 sal
= find_pc_line (b
->address
, 0);
587 filename
= symtab_to_filename (sal
.symtab
);
588 if (filename
== NULL
)
591 sprintf (buf
, "gdbtk_tcl_breakpoint %s %d 0x%lx %d {%s}", action
, b
->number
,
592 (long)b
->address
, b
->line_number
, filename
);
594 v
= Tcl_Eval (interp
, buf
);
598 gdbtk_fputs (interp
->result
, gdb_stdout
);
599 gdbtk_fputs ("\n", gdb_stdout
);
604 gdbtk_create_breakpoint(b
)
605 struct breakpoint
*b
;
607 breakpoint_notify (b
, "create");
611 gdbtk_delete_breakpoint(b
)
612 struct breakpoint
*b
;
614 breakpoint_notify (b
, "delete");
618 gdbtk_modify_breakpoint(b
)
619 struct breakpoint
*b
;
621 breakpoint_notify (b
, "modify");
624 /* This implements the TCL command `gdb_loc', which returns a list */
625 /* consisting of the following: */
626 /* basename, function name, filename, line number, address, current pc */
629 gdb_loc (clientData
, interp
, argc
, argv
)
630 ClientData clientData
;
636 struct symtab_and_line sal
;
637 char *funcname
, *fname
;
640 if (!have_full_symbols () && !have_partial_symbols ())
642 Tcl_SetResult (interp
, "No symbol table is loaded", TCL_STATIC
);
648 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
650 /* Note - this next line is not correct on all architectures. */
651 /* For a graphical debugged we really want to highlight the */
652 /* assembly line that called the next function on the stack. */
653 /* Many architectures have the next instruction saved as the */
654 /* pc on the stack, so what happens is the next instruction is hughlighted. */
656 pc
= selected_frame
->pc
;
657 sal
= find_pc_line (selected_frame
->pc
,
658 selected_frame
->next
!= NULL
659 && !selected_frame
->next
->signal_handler_caller
660 && !frame_in_dummy (selected_frame
->next
));
665 sal
= find_pc_line (stop_pc
, 0);
670 struct symtabs_and_lines sals
;
673 sals
= decode_line_spec (argv
[1], 1);
680 error ("Ambiguous line spec");
685 error ("wrong # args");
688 Tcl_DStringAppendElement (result_ptr
, sal
.symtab
->filename
);
690 Tcl_DStringAppendElement (result_ptr
, "");
692 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
693 fname
= cplus_demangle (funcname
, 0);
696 Tcl_DStringAppendElement (result_ptr
, fname
);
700 Tcl_DStringAppendElement (result_ptr
, funcname
);
701 filename
= symtab_to_filename (sal
.symtab
);
702 if (filename
== NULL
)
705 Tcl_DStringAppendElement (result_ptr
, filename
);
706 dsprintf_append_element (result_ptr
, "%d", sal
.line
); /* line number */
707 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
708 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
712 /* This implements the TCL command `gdb_eval'. */
715 gdb_eval (clientData
, interp
, argc
, argv
)
716 ClientData clientData
;
721 struct expression
*expr
;
722 struct cleanup
*old_chain
;
726 error ("wrong # args");
728 expr
= parse_expression (argv
[1]);
730 old_chain
= make_cleanup (free_current_contents
, &expr
);
732 val
= evaluate_expression (expr
);
734 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
735 gdb_stdout
, 0, 0, 0, 0);
737 do_cleanups (old_chain
);
742 /* gdb_get_mem addr form size num aschar*/
743 /* dump a block of memory */
744 /* addr: address of data to dump */
745 /* form: a char indicating format */
746 /* size: size of each element; 1,2,4, or 8 bytes*/
747 /* num: the number of bytes to read */
748 /* acshar: an optional ascii character to use in ASCII dump */
749 /* returns a list of elements followed by an optional */
753 gdb_get_mem (clientData
, interp
, argc
, argv
)
754 ClientData clientData
;
759 int size
, asize
, i
, j
, bc
;
761 int nbytes
, rnum
, bpr
;
762 char format
, c
, *ptr
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
763 struct type
*val_type
;
765 if (argc
< 6 || argc
> 7)
767 interp
->result
= "addr format size bytes bytes_per_row ?ascii_char?";
771 size
= (int)strtoul(argv
[3],(char **)NULL
,0);
772 nbytes
= (int)strtoul(argv
[4],(char **)NULL
,0);
773 bpr
= (int)strtoul(argv
[5],(char **)NULL
,0);
774 if (nbytes
<= 0 || bpr
<= 0 || size
<= 0)
776 interp
->result
= "Invalid number of bytes.";
780 addr
= (CORE_ADDR
)strtoul(argv
[1],(char **)NULL
,0);
782 mbuf
= (char *)malloc (nbytes
+32);
785 interp
->result
= "Out of memory.";
788 memset (mbuf
, 0, nbytes
+32);
791 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
800 val_type
= builtin_type_char
;
804 val_type
= builtin_type_short
;
808 val_type
= builtin_type_int
;
812 val_type
= builtin_type_long_long
;
816 val_type
= builtin_type_char
;
820 bc
= 0; /* count of bytes in a row */
821 buff
[0] = '"'; /* buffer for ascii dump */
822 bptr
= &buff
[1]; /* pointer for ascii dump */
824 for (i
=0; i
< nbytes
; i
+= size
)
828 fputs_unfiltered ("N/A ", gdb_stdout
);
830 for ( j
= 0; j
< size
; j
++)
835 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
836 fputs_unfiltered (" ", gdb_stdout
);
839 for ( j
= 0; j
< size
; j
++)
842 if (c
< 32 || c
> 126)
854 if (aschar
&& (bc
>= bpr
))
856 /* end of row. print it and reset variables */
861 fputs_unfiltered (buff
, gdb_stdout
);
871 map_arg_registers (argc
, argv
, func
, argp
)
874 void (*func
) PARAMS ((int regnum
, void *argp
));
879 /* Note that the test for a valid register must include checking the
880 reg_names array because NUM_REGS may be allocated for the union of the
881 register sets within a family of related processors. In this case, the
882 trailing entries of reg_names will change depending upon the particular
883 processor being debugged. */
885 if (argc
== 0) /* No args, just do all the regs */
889 && reg_names
[regnum
] != NULL
890 && *reg_names
[regnum
] != '\000';
897 /* Else, list of register #s, just do listed regs */
898 for (; argc
> 0; argc
--, argv
++)
900 regnum
= atoi (*argv
);
904 && reg_names
[regnum
] != NULL
905 && *reg_names
[regnum
] != '\000')
908 error ("bad register number");
915 get_register_name (regnum
, argp
)
917 void *argp
; /* Ignored */
919 Tcl_DStringAppendElement (result_ptr
, reg_names
[regnum
]);
922 /* This implements the TCL command `gdb_regnames', which returns a list of
923 all of the register names. */
926 gdb_regnames (clientData
, interp
, argc
, argv
)
927 ClientData clientData
;
935 return map_arg_registers (argc
, argv
, get_register_name
, NULL
);
938 #ifndef REGISTER_CONVERTIBLE
939 #define REGISTER_CONVERTIBLE(x) (0 != 0)
942 #ifndef REGISTER_CONVERT_TO_VIRTUAL
943 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
946 #ifndef INVALID_FLOAT
947 #define INVALID_FLOAT(x, y) (0 != 0)
951 get_register (regnum
, fp
)
955 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
956 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
957 int format
= (int)fp
;
962 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
964 Tcl_DStringAppendElement (result_ptr
, "Optimized out");
968 /* Convert raw data to virtual format if necessary. */
970 if (REGISTER_CONVERTIBLE (regnum
))
972 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
973 raw_buffer
, virtual_buffer
);
976 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
981 printf_filtered ("0x");
982 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
984 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
985 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
986 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
990 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
991 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
993 Tcl_DStringAppend (result_ptr
, " ", -1);
997 get_pc_register (clientData
, interp
, argc
, argv
)
998 ClientData clientData
;
1003 sprintf(interp
->result
,"0x%llx",(long long)read_register(PC_REGNUM
));
1008 gdb_fetch_registers (clientData
, interp
, argc
, argv
)
1009 ClientData clientData
;
1017 error ("wrong # args");
1023 return map_arg_registers (argc
, argv
, get_register
, (void *) format
);
1026 /* This contains the previous values of the registers, since the last call to
1027 gdb_changed_register_list. */
1029 static char old_regs
[REGISTER_BYTES
];
1032 register_changed_p (regnum
, argp
)
1034 void *argp
; /* Ignored */
1036 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1038 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1041 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1042 REGISTER_RAW_SIZE (regnum
)) == 0)
1045 /* Found a changed register. Save new value and return its number. */
1047 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1048 REGISTER_RAW_SIZE (regnum
));
1050 dsprintf_append_element (result_ptr
, "%d", regnum
);
1054 gdb_changed_register_list (clientData
, interp
, argc
, argv
)
1055 ClientData clientData
;
1063 return map_arg_registers (argc
, argv
, register_changed_p
, NULL
);
1066 /* This implements the tcl command "gdb_immediate", which does exactly
1067 the same thing as gdb_cmd, except NONE of its outut is buffered. */
1069 gdb_immediate_command (clientData
, interp
, argc
, argv
)
1070 ClientData clientData
;
1075 Tcl_DString
*save_ptr
= NULL
;
1078 error ("wrong # args");
1080 if (running_now
|| load_in_progress
)
1083 Tcl_DStringAppend (result_ptr
, "", -1);
1084 save_ptr
= result_ptr
;
1087 execute_command (argv
[1], 1);
1089 bpstat_do_actions (&stop_bpstat
);
1091 result_ptr
= save_ptr
;
1096 /* This implements the TCL command `gdb_cmd', which sends its argument into
1097 the GDB command scanner. */
1100 gdb_cmd (clientData
, interp
, argc
, argv
)
1101 ClientData clientData
;
1106 Tcl_DString
*save_ptr
= NULL
;
1109 error ("wrong # args");
1111 if (running_now
|| load_in_progress
)
1114 /* for the load instruction (and possibly others later) we
1115 set result_ptr to NULL so gdbtk_fputs() will not buffer
1116 all the data until the command is finished. */
1118 if (strncmp ("load ", argv
[1], 5) == 0
1119 || strncmp ("while ", argv
[1], 6) == 0)
1121 Tcl_DStringAppend (result_ptr
, "", -1);
1122 save_ptr
= result_ptr
;
1124 load_in_progress
= 1;
1126 /* On Windows, use timer interrupts so that the user can cancel
1127 the download. FIXME: We may have to do something on other
1130 gdbtk_start_timer ();
1134 execute_command (argv
[1], 1);
1137 if (load_in_progress
)
1138 gdbtk_stop_timer ();
1141 load_in_progress
= 0;
1142 bpstat_do_actions (&stop_bpstat
);
1145 result_ptr
= save_ptr
;
1150 /* Client of call_wrapper - this routine performs the actual call to
1151 the client function. */
1153 struct wrapped_call_args
1164 struct wrapped_call_args
*args
;
1166 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->argc
, args
->argv
);
1170 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
1171 handles cleanups, and calls to return_to_top_level (usually via error).
1172 This is necessary in order to prevent a longjmp out of the bowels of Tk,
1173 possibly leaving things in a bad state. Since this routine can be called
1174 recursively, it needs to save and restore the contents of the jmp_buf as
1178 call_wrapper (clientData
, interp
, argc
, argv
)
1179 ClientData clientData
;
1184 struct wrapped_call_args wrapped_args
;
1185 Tcl_DString result
, *old_result_ptr
;
1186 Tcl_DString error_string
, *old_error_string_ptr
;
1188 Tcl_DStringInit (&result
);
1189 old_result_ptr
= result_ptr
;
1190 result_ptr
= &result
;
1192 Tcl_DStringInit (&error_string
);
1193 old_error_string_ptr
= error_string_ptr
;
1194 error_string_ptr
= &error_string
;
1196 wrapped_args
.func
= (Tcl_CmdProc
*)clientData
;
1197 wrapped_args
.interp
= interp
;
1198 wrapped_args
.argc
= argc
;
1199 wrapped_args
.argv
= argv
;
1200 wrapped_args
.val
= 0;
1202 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
1204 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
1207 /* Make sure the timer interrupts are turned off. */
1208 if (gdbtk_timer_going
)
1209 gdbtk_stop_timer ();
1212 gdb_flush (gdb_stderr
); /* Flush error output */
1213 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
1215 /* In case of an error, we may need to force the GUI into idle
1216 mode because gdbtk_call_command may have bombed out while in
1217 the command routine. */
1220 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1223 /* do not suppress any errors -- a remote target could have errored */
1224 load_in_progress
= 0;
1226 if (Tcl_DStringLength (&error_string
) == 0)
1228 Tcl_DStringResult (interp
, &result
);
1229 Tcl_DStringFree (&error_string
);
1231 else if (Tcl_DStringLength (&result
) == 0)
1233 Tcl_DStringResult (interp
, &error_string
);
1234 Tcl_DStringFree (&result
);
1235 Tcl_DStringFree (&error_string
);
1239 Tcl_ResetResult (interp
);
1240 Tcl_AppendResult (interp
, Tcl_DStringValue (&result
),
1241 Tcl_DStringValue (&error_string
), (char *) NULL
);
1242 Tcl_DStringFree (&result
);
1243 Tcl_DStringFree (&error_string
);
1246 result_ptr
= old_result_ptr
;
1247 error_string_ptr
= old_error_string_ptr
;
1253 return wrapped_args
.val
;
1257 comp_files (file1
, file2
)
1258 const char *file1
[], *file2
[];
1260 return strcmp(*file1
,*file2
);
1264 gdb_listfiles (clientData
, interp
, objc
, objv
)
1265 ClientData clientData
;
1268 Tcl_Obj
*CONST objv
[];
1270 struct objfile
*objfile
;
1271 struct partial_symtab
*psymtab
;
1272 struct symtab
*symtab
;
1273 char *lastfile
, *pathname
, *files
[1000];
1274 int i
, numfiles
= 0, len
= 0;
1279 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1283 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1285 mylist
= Tcl_NewListObj (0, NULL
);
1287 ALL_PSYMTABS (objfile
, psymtab
)
1291 if (psymtab
->filename
)
1292 files
[numfiles
++] = basename(psymtab
->filename
);
1294 else if (!strcmp(psymtab
->filename
,basename(psymtab
->filename
))
1295 || !strncmp(pathname
,psymtab
->filename
,len
))
1296 if (psymtab
->filename
)
1297 files
[numfiles
++] = basename(psymtab
->filename
);
1300 ALL_SYMTABS (objfile
, symtab
)
1304 if (symtab
->filename
)
1305 files
[numfiles
++] = basename(symtab
->filename
);
1307 else if (!strcmp(symtab
->filename
,basename(symtab
->filename
))
1308 || !strncmp(pathname
,symtab
->filename
,len
))
1309 if (symtab
->filename
)
1310 files
[numfiles
++] = basename(symtab
->filename
);
1313 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1316 for (i
= 0; i
< numfiles
; i
++)
1318 if (strcmp(files
[i
],lastfile
))
1319 Tcl_ListObjAppendElement (interp
, mylist
, Tcl_NewStringObj(files
[i
], -1));
1320 lastfile
= files
[i
];
1322 Tcl_SetObjResult (interp
, mylist
);
1327 gdb_listfuncs (clientData
, interp
, argc
, argv
)
1328 ClientData clientData
;
1333 struct symtab
*symtab
;
1334 struct blockvector
*bv
;
1341 error ("wrong # args");
1343 symtab
= full_lookup_symtab (argv
[1]);
1345 error ("No such file");
1347 bv
= BLOCKVECTOR (symtab
);
1348 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1350 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1351 /* Skip the sort if this block is always sorted. */
1352 if (!BLOCK_SHOULD_SORT (b
))
1353 sort_block_syms (b
);
1354 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1356 sym
= BLOCK_SYM (b
, j
);
1357 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1360 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1363 sprintf (buf
,"{%s} 1", name
);
1366 sprintf (buf
,"{%s} 0", SYMBOL_NAME(sym
));
1367 Tcl_DStringAppendElement (result_ptr
, buf
);
1375 target_stop_wrapper (args
)
1383 gdb_stop (clientData
, interp
, argc
, argv
)
1384 ClientData clientData
;
1391 catch_errors (target_stop_wrapper
, NULL
, "",
1395 quit_flag
= 1; /* hope something sees this */
1400 /* Prepare to accept a new executable file. This is called when we
1401 want to clear away everything we know about the old file, without
1402 asking the user. The Tcl code will have already asked the user if
1403 necessary. After this is called, we should be able to run the
1404 `file' command without getting any questions. */
1407 gdb_clear_file (clientData
, interp
, argc
, argv
)
1408 ClientData clientData
;
1413 if (inferior_pid
!= 0 && target_has_execution
)
1416 target_detach (NULL
, 0);
1421 if (target_has_execution
)
1424 symbol_file_command (NULL
, 0);
1426 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
1427 clear it here. FIXME: This seems like an abstraction violation
1434 /* Ask the user to confirm an exit request. */
1437 gdb_confirm_quit (clientData
, interp
, argc
, argv
)
1438 ClientData clientData
;
1445 ret
= quit_confirm ();
1446 Tcl_DStringAppendElement (result_ptr
, ret
? "1" : "0");
1450 /* Quit without asking for confirmation. */
1453 gdb_force_quit (clientData
, interp
, argc
, argv
)
1454 ClientData clientData
;
1459 quit_force ((char *) NULL
, 1);
1463 /* This implements the TCL command `gdb_disassemble'. */
1466 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
1470 disassemble_info
*info
;
1472 extern struct target_ops exec_ops
;
1476 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
1487 /* We need a different sort of line table from the normal one cuz we can't
1488 depend upon implicit line-end pc's for lines. This is because of the
1489 reordering we are about to do. */
1491 struct my_line_entry
{
1498 compare_lines (mle1p
, mle2p
)
1502 struct my_line_entry
*mle1
, *mle2
;
1505 mle1
= (struct my_line_entry
*) mle1p
;
1506 mle2
= (struct my_line_entry
*) mle2p
;
1508 val
= mle1
->line
- mle2
->line
;
1513 return mle1
->start_pc
- mle2
->start_pc
;
1517 gdb_disassemble (clientData
, interp
, argc
, argv
)
1518 ClientData clientData
;
1523 CORE_ADDR pc
, low
, high
;
1524 int mixed_source_and_assembly
;
1525 static disassemble_info di
;
1526 static int di_initialized
;
1528 if (! di_initialized
)
1530 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
1531 (fprintf_ftype
) fprintf_unfiltered
);
1532 di
.flavour
= bfd_target_unknown_flavour
;
1533 di
.memory_error_func
= dis_asm_memory_error
;
1534 di
.print_address_func
= dis_asm_print_address
;
1538 di
.mach
= tm_print_insn_info
.mach
;
1539 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
1540 di
.endian
= BFD_ENDIAN_BIG
;
1542 di
.endian
= BFD_ENDIAN_LITTLE
;
1544 if (argc
!= 3 && argc
!= 4)
1545 error ("wrong # args");
1547 if (strcmp (argv
[1], "source") == 0)
1548 mixed_source_and_assembly
= 1;
1549 else if (strcmp (argv
[1], "nosource") == 0)
1550 mixed_source_and_assembly
= 0;
1552 error ("First arg must be 'source' or 'nosource'");
1554 low
= parse_and_eval_address (argv
[2]);
1558 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
1559 error ("No function contains specified address");
1562 high
= parse_and_eval_address (argv
[3]);
1564 /* If disassemble_from_exec == -1, then we use the following heuristic to
1565 determine whether or not to do disassembly from target memory or from the
1568 If we're debugging a local process, read target memory, instead of the
1569 exec file. This makes disassembly of functions in shared libs work
1572 Else, we're debugging a remote process, and should disassemble from the
1573 exec file for speed. However, this is no good if the target modifies its
1574 code (for relocation, or whatever).
1577 if (disassemble_from_exec
== -1)
1578 if (strcmp (target_shortname
, "child") == 0
1579 || strcmp (target_shortname
, "procfs") == 0
1580 || strcmp (target_shortname
, "vxprocess") == 0)
1581 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
1583 disassemble_from_exec
= 1; /* It's remote, read the exec file */
1585 if (disassemble_from_exec
)
1586 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
1588 di
.read_memory_func
= dis_asm_read_memory
;
1590 /* If just doing straight assembly, all we need to do is disassemble
1591 everything between low and high. If doing mixed source/assembly, we've
1592 got a totally different path to follow. */
1594 if (mixed_source_and_assembly
)
1595 { /* Come here for mixed source/assembly */
1596 /* The idea here is to present a source-O-centric view of a function to
1597 the user. This means that things are presented in source order, with
1598 (possibly) out of order assembly immediately following. */
1599 struct symtab
*symtab
;
1600 struct linetable_entry
*le
;
1603 struct my_line_entry
*mle
;
1604 struct symtab_and_line sal
;
1609 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
1614 /* First, convert the linetable to a bunch of my_line_entry's. */
1616 le
= symtab
->linetable
->item
;
1617 nlines
= symtab
->linetable
->nitems
;
1622 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
1626 /* Copy linetable entries for this function into our data structure, creating
1627 end_pc's and setting out_of_order as appropriate. */
1629 /* First, skip all the preceding functions. */
1631 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
1633 /* Now, copy all entries before the end of this function. */
1636 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
1638 if (le
[i
].line
== le
[i
+ 1].line
1639 && le
[i
].pc
== le
[i
+ 1].pc
)
1640 continue; /* Ignore duplicates */
1642 mle
[newlines
].line
= le
[i
].line
;
1643 if (le
[i
].line
> le
[i
+ 1].line
)
1645 mle
[newlines
].start_pc
= le
[i
].pc
;
1646 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
1650 /* If we're on the last line, and it's part of the function, then we need to
1651 get the end pc in a special way. */
1656 mle
[newlines
].line
= le
[i
].line
;
1657 mle
[newlines
].start_pc
= le
[i
].pc
;
1658 sal
= find_pc_line (le
[i
].pc
, 0);
1659 mle
[newlines
].end_pc
= sal
.end
;
1663 /* Now, sort mle by line #s (and, then by addresses within lines). */
1666 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
1668 /* Now, for each line entry, emit the specified lines (unless they have been
1669 emitted before), followed by the assembly code for that line. */
1671 next_line
= 0; /* Force out first line */
1672 for (i
= 0; i
< newlines
; i
++)
1674 /* Print out everything from next_line to the current line. */
1676 if (mle
[i
].line
>= next_line
)
1679 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
1681 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
1683 next_line
= mle
[i
].line
+ 1;
1686 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
1689 fputs_unfiltered (" ", gdb_stdout
);
1690 print_address (pc
, gdb_stdout
);
1691 fputs_unfiltered (":\t ", gdb_stdout
);
1692 pc
+= (*tm_print_insn
) (pc
, &di
);
1693 fputs_unfiltered ("\n", gdb_stdout
);
1700 for (pc
= low
; pc
< high
; )
1703 fputs_unfiltered (" ", gdb_stdout
);
1704 print_address (pc
, gdb_stdout
);
1705 fputs_unfiltered (":\t ", gdb_stdout
);
1706 pc
+= (*tm_print_insn
) (pc
, &di
);
1707 fputs_unfiltered ("\n", gdb_stdout
);
1711 gdb_flush (gdb_stdout
);
1717 tk_command (cmd
, from_tty
)
1723 struct cleanup
*old_chain
;
1725 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1727 error_no_arg ("tcl command to interpret");
1729 retval
= Tcl_Eval (interp
, cmd
);
1731 result
= strdup (interp
->result
);
1733 old_chain
= make_cleanup (free
, result
);
1735 if (retval
!= TCL_OK
)
1738 printf_unfiltered ("%s\n", result
);
1740 do_cleanups (old_chain
);
1744 cleanup_init (ignored
)
1748 Tcl_DeleteInterp (interp
);
1752 /* Come here during long calculations to check for GUI events. Usually invoked
1753 via the QUIT macro. */
1756 gdbtk_interactive ()
1758 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1761 /* Come here when there is activity on the X file descriptor. */
1767 static int in_x_event
= 0;
1768 static Tcl_Obj
*varname
= NULL
;
1770 if (in_x_event
|| in_fputs
)
1775 /* Process pending events */
1776 while (Tcl_DoOneEvent (TCL_DONT_WAIT
|TCL_ALL_EVENTS
) != 0)
1779 if (load_in_progress
)
1782 if (varname
== NULL
)
1784 Tcl_Obj
*varnamestrobj
= Tcl_NewStringObj("download_cancel_ok",-1);
1785 varname
= Tcl_ObjGetVar2(interp
,varnamestrobj
,NULL
,TCL_GLOBAL_ONLY
);
1787 if ((Tcl_GetIntFromObj(interp
,varname
,&val
) == TCL_OK
) && val
)
1803 /* For Cygwin32, we use a timer to periodically check for Windows
1804 messages. FIXME: It would be better to not poll, but to instead
1805 rewrite the target_wait routines to serve as input sources.
1806 Unfortunately, that will be a lot of work. */
1807 static sigset_t nullsigmask
;
1808 static struct sigaction act1
, act2
;
1809 static struct itimerval it_on
, it_off
;
1812 gdbtk_start_timer ()
1814 static int first
= 1;
1815 /*TclDebug ("Starting timer....");*/
1818 /* first time called, set up all the structs */
1820 sigemptyset (&nullsigmask
);
1822 act1
.sa_handler
= x_event
;
1823 act1
.sa_mask
= nullsigmask
;
1826 act2
.sa_handler
= SIG_IGN
;
1827 act2
.sa_mask
= nullsigmask
;
1830 it_on
.it_interval
.tv_sec
= 0;
1831 it_on
.it_interval
.tv_usec
= 500000; /* .5 sec */
1832 it_on
.it_value
.tv_sec
= 0;
1833 it_on
.it_value
.tv_usec
= 500000;
1835 it_off
.it_interval
.tv_sec
= 0;
1836 it_off
.it_interval
.tv_usec
= 0;
1837 it_off
.it_value
.tv_sec
= 0;
1838 it_off
.it_value
.tv_usec
= 0;
1840 sigaction (SIGALRM
, &act1
, NULL
);
1841 setitimer (ITIMER_REAL
, &it_on
, NULL
);
1842 gdbtk_timer_going
= 1;
1848 gdbtk_timer_going
= 0;
1849 /*TclDebug ("Stopping timer.");*/
1850 setitimer (ITIMER_REAL
, &it_off
, NULL
);
1851 sigaction (SIGALRM
, &act2
, NULL
);
1856 /* This hook function is called whenever we want to wait for the
1860 gdbtk_wait (pid
, ourstatus
)
1862 struct target_waitstatus
*ourstatus
;
1865 struct sigaction action
;
1866 static sigset_t nullsigmask
= {0};
1870 /* Needed for SunOS 4.1.x */
1871 #define SA_RESTART 0
1874 action
.sa_handler
= x_event
;
1875 action
.sa_mask
= nullsigmask
;
1876 action
.sa_flags
= SA_RESTART
;
1877 sigaction(SIGIO
, &action
, NULL
);
1880 pid
= target_wait (pid
, ourstatus
);
1883 action
.sa_handler
= SIG_IGN
;
1884 sigaction(SIGIO
, &action
, NULL
);
1890 /* This is called from execute_command, and provides a wrapper around
1891 various command routines in a place where both protocol messages and
1892 user input both flow through. Mostly this is used for indicating whether
1893 the target process is running or not.
1897 gdbtk_call_command (cmdblk
, arg
, from_tty
)
1898 struct cmd_list_element
*cmdblk
;
1903 if (cmdblk
->class == class_run
|| cmdblk
->class == class_trace
)
1906 Tcl_Eval (interp
, "gdbtk_tcl_busy");
1907 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1909 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1912 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1915 /* This function is called instead of gdb's internal command loop. This is the
1916 last chance to do anything before entering the main Tk event loop. */
1921 extern GDB_FILE
*instream
;
1923 /* We no longer want to use stdin as the command input stream */
1926 if (Tcl_Eval (interp
, "gdbtk_tcl_preloop") != TCL_OK
)
1930 /* Force errorInfo to be set up propertly. */
1931 Tcl_AddErrorInfo (interp
, "");
1933 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
1935 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
1937 fputs_unfiltered (msg
, gdb_stderr
);
1948 /* gdbtk_init installs this function as a final cleanup. */
1951 gdbtk_cleanup (dummy
)
1955 struct ide_event_handle
*h
= (struct ide_event_handle
*) dummy
;
1957 ide_interface_deregister_all (h
);
1962 /* Initialize gdbtk. */
1965 gdbtk_init ( argv0
)
1968 struct cleanup
*old_chain
;
1969 char *lib
, *gdbtk_lib
, *gdbtk_lib_tmp
, *gdbtk_file
;
1972 struct sigaction action
;
1973 static sigset_t nullsigmask
= {0};
1976 /* start-sanitize-ide */
1977 struct ide_event_handle
*h
;
1980 /* end-sanitize-ide */
1983 /* If there is no DISPLAY environment variable, Tk_Init below will fail,
1984 causing gdb to abort. If instead we simply return here, gdb will
1985 gracefully degrade to using the command line interface. */
1988 if (getenv ("DISPLAY") == NULL
)
1992 old_chain
= make_cleanup (cleanup_init
, 0);
1994 /* First init tcl and tk. */
1995 Tcl_FindExecutable (argv0
);
1996 interp
= Tcl_CreateInterp ();
1998 #ifdef TCL_MEM_DEBUG
1999 Tcl_InitMemory (interp
);
2003 error ("Tcl_CreateInterp failed");
2005 if (Tcl_Init(interp
) != TCL_OK
)
2006 error ("Tcl_Init failed: %s", interp
->result
);
2009 /* For the IDE we register the cleanup later, after we've
2010 initialized events. */
2011 make_final_cleanup (gdbtk_cleanup
, NULL
);
2014 /* Initialize the Paths variable. */
2015 if (ide_initialize_paths (interp
, "gdbtcl") != TCL_OK
)
2016 error ("ide_initialize_paths failed: %s", interp
->result
);
2019 /* start-sanitize-ide */
2020 /* Find the directory where we expect to find idemanager. We ignore
2021 errors since it doesn't really matter if this fails. */
2022 libexecdir
= Tcl_GetVar2 (interp
, "Paths", "libexecdir", TCL_GLOBAL_ONLY
);
2026 h
= ide_event_init_from_environment (&errmsg
, libexecdir
);
2027 make_final_cleanup (gdbtk_cleanup
, h
);
2030 Tcl_AppendResult (interp
, "can't initialize event system: ", errmsg
,
2032 fprintf(stderr
, "WARNING: ide_event_init_client failed: %s\n", interp
->result
);
2034 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
2038 if (ide_create_tclevent_command (interp
, h
) != TCL_OK
)
2039 error ("ide_create_tclevent_command failed: %s", interp
->result
);
2041 if (ide_create_edit_command (interp
, h
) != TCL_OK
)
2042 error ("ide_create_edit_command failed: %s", interp
->result
);
2044 if (ide_create_property_command (interp
, h
) != TCL_OK
)
2045 error ("ide_create_property_command failed: %s", interp
->result
);
2047 if (ide_create_build_command (interp
, h
) != TCL_OK
)
2048 error ("ide_create_build_command failed: %s", interp
->result
);
2050 if (ide_create_window_register_command (interp
, h
, "gdb-restore")
2052 error ("ide_create_window_register_command failed: %s",
2055 if (ide_create_window_command (interp
, h
) != TCL_OK
)
2056 error ("ide_create_window_command failed: %s", interp
->result
);
2058 if (ide_create_exit_command (interp
, h
) != TCL_OK
)
2059 error ("ide_create_exit_command failed: %s", interp
->result
);
2061 if (ide_create_help_command (interp
) != TCL_OK
)
2062 error ("ide_create_help_command failed: %s", interp
->result
);
2065 if (ide_initialize (interp, "gdb") != TCL_OK)
2066 error ("ide_initialize failed: %s", interp->result);
2069 Tcl_SetVar (interp
, "GDBTK_IDE", "1", 0);
2070 Tcl_SetVar (interp
, "IDE", "1", TCL_GLOBAL_ONLY
);
2072 /* end-sanitize-ide */
2074 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
2077 /* We don't want to open the X connection until we've done all the
2078 IDE initialization. Otherwise, goofy looking unfinished windows
2079 pop up when ILU drops into the TCL event loop. */
2081 if (Tk_Init(interp
) != TCL_OK
)
2082 error ("Tk_Init failed: %s", interp
->result
);
2084 if (Itcl_Init(interp
) == TCL_ERROR
)
2085 error ("Itcl_Init failed: %s", interp
->result
);
2087 if (Tix_Init(interp
) != TCL_OK
)
2088 error ("Tix_Init failed: %s", interp
->result
);
2091 if (ide_create_messagebox_command (interp
) != TCL_OK
)
2092 error ("messagebox command initialization failed");
2093 /* On Windows, create a sizebox widget command */
2094 if (ide_create_sizebox_command (interp
) != TCL_OK
)
2095 error ("sizebox creation failed");
2096 if (ide_create_winprint_command (interp
) != TCL_OK
)
2097 error ("windows print code initialization failed");
2098 /* start-sanitize-ide */
2099 /* An interface to ShellExecute. */
2100 if (ide_create_shell_execute_command (interp
) != TCL_OK
)
2101 error ("shell execute command initialization failed");
2102 /* end-sanitize-ide */
2103 if (ide_create_win_grab_command (interp
) != TCL_OK
)
2104 error ("grab support command initialization failed");
2105 /* Path conversion functions. */
2106 if (ide_create_cygwin_path_command (interp
) != TCL_OK
)
2107 error ("cygwin path command initialization failed");
2110 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
2111 Tcl_CreateCommand (interp
, "gdb_immediate", call_wrapper
,
2112 gdb_immediate_command
, NULL
);
2113 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
2114 Tcl_CreateCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
2115 Tcl_CreateObjCommand (interp
, "gdb_listfiles", gdb_listfiles
, NULL
, NULL
);
2116 Tcl_CreateCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
2118 Tcl_CreateCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
2120 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
2121 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
2122 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
2123 gdb_fetch_registers
, NULL
);
2124 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
2125 gdb_changed_register_list
, NULL
);
2126 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
2127 gdb_disassemble
, NULL
);
2128 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
2129 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
2130 gdb_get_breakpoint_list
, NULL
);
2131 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
2132 gdb_get_breakpoint_info
, NULL
);
2133 Tcl_CreateCommand (interp
, "gdb_clear_file", call_wrapper
,
2134 gdb_clear_file
, NULL
);
2135 Tcl_CreateCommand (interp
, "gdb_confirm_quit", call_wrapper
,
2136 gdb_confirm_quit
, NULL
);
2137 Tcl_CreateCommand (interp
, "gdb_force_quit", call_wrapper
,
2138 gdb_force_quit
, NULL
);
2139 Tcl_CreateCommand (interp
, "gdb_target_has_execution",
2140 gdb_target_has_execution_command
,
2142 Tcl_CreateObjCommand (interp
, "gdb_load_info", gdb_load_info
, NULL
, NULL
);
2143 Tcl_CreateObjCommand (interp
, "gdb_get_locals", gdb_get_vars_command
,
2144 (ClientData
) 0, NULL
);
2145 Tcl_CreateObjCommand (interp
, "gdb_get_args", gdb_get_vars_command
,
2146 (ClientData
) 1, NULL
);
2147 Tcl_CreateObjCommand (interp
, "gdb_get_function", gdb_get_function_command
,
2149 Tcl_CreateObjCommand (interp
, "gdb_get_line", gdb_get_line_command
,
2151 Tcl_CreateObjCommand (interp
, "gdb_get_file", gdb_get_file_command
,
2153 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
2154 gdb_tracepoint_exists_command
, NULL
, NULL
);
2155 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
2156 gdb_get_tracepoint_info
, NULL
, NULL
);
2157 Tcl_CreateObjCommand (interp
, "gdb_actions",
2158 gdb_actions_command
, NULL
, NULL
);
2159 Tcl_CreateObjCommand (interp
, "gdb_prompt",
2160 gdb_prompt_command
, NULL
, NULL
);
2161 Tcl_CreateObjCommand (interp
, "gdb_find_file",
2162 gdb_find_file_command
, NULL
, NULL
);
2163 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
2164 gdb_get_tracepoint_list
, NULL
, NULL
);
2165 Tcl_CreateCommand (interp
, "gdb_pc_reg", get_pc_register
, NULL
, NULL
);
2166 Tcl_CreateObjCommand (interp
, "gdb_loadfile", gdb_loadfile
, NULL
, NULL
);
2167 Tcl_CreateObjCommand (interp
, "gdb_set_bp", gdb_set_bp
, NULL
, NULL
);
2169 command_loop_hook
= tk_command_loop
;
2170 print_frame_info_listing_hook
= gdbtk_print_frame_info
;
2171 query_hook
= gdbtk_query
;
2172 flush_hook
= gdbtk_flush
;
2173 create_breakpoint_hook
= gdbtk_create_breakpoint
;
2174 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
2175 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
2176 interactive_hook
= gdbtk_interactive
;
2177 target_wait_hook
= gdbtk_wait
;
2178 call_command_hook
= gdbtk_call_command
;
2179 readline_begin_hook
= gdbtk_readline_begin
;
2180 readline_hook
= gdbtk_readline
;
2181 readline_end_hook
= gdbtk_readline_end
;
2182 ui_load_progress_hook
= gdbtk_load_hash
;
2183 pre_add_symbol_hook
= gdbtk_pre_add_symbol
;
2184 post_add_symbol_hook
= gdbtk_post_add_symbol
;
2185 create_tracepoint_hook
= gdbtk_create_tracepoint
;
2186 delete_tracepoint_hook
= gdbtk_delete_tracepoint
;
2187 modify_tracepoint_hook
= gdbtk_modify_tracepoint
;
2188 pc_changed_hook
= pc_changed
;
2190 annotate_starting_hook
= gdbtk_annotate_starting
;
2191 annotate_stopped_hook
= gdbtk_annotate_stopped
;
2192 annotate_signalled_hook
= gdbtk_annotate_signalled
;
2193 annotate_exited_hook
= gdbtk_annotate_exited
;
2194 ui_loop_hook
= x_event
;
2197 /* Get the file descriptor for the X server */
2199 x_fd
= ConnectionNumber (Tk_Display (Tk_MainWindow (interp
)));
2201 /* Setup for I/O interrupts */
2203 action
.sa_mask
= nullsigmask
;
2204 action
.sa_flags
= 0;
2205 action
.sa_handler
= SIG_IGN
;
2206 sigaction(SIGIO
, &action
, NULL
);
2210 if (ioctl (x_fd
, FIOASYNC
, &i
))
2211 perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
2215 if (ioctl (x_fd
, SIOCSPGRP
, &i
))
2216 perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
2221 if (fcntl (x_fd
, F_SETOWN
, i
))
2222 perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
2223 #endif /* F_SETOWN */
2224 #endif /* !SIOCSPGRP */
2227 if (ioctl (x_fd
, I_SETSIG
, S_INPUT
|S_RDNORM
) < 0)
2228 perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
2231 #endif /* ifndef FIOASYNC */
2234 add_com ("tk", class_obscure
, tk_command
,
2235 "Send a command directly into tk.");
2237 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
2240 /* find the gdb tcl library and source main.tcl */
2242 gdbtk_lib
= getenv ("GDBTK_LIBRARY");
2244 if (access ("gdbtcl/main.tcl", R_OK
) == 0)
2245 gdbtk_lib
= "gdbtcl";
2247 gdbtk_lib
= GDBTK_LIBRARY
;
2249 gdbtk_lib_tmp
= xstrdup (gdbtk_lib
);
2252 /* see if GDBTK_LIBRARY is a path list */
2253 lib
= strtok (gdbtk_lib_tmp
, GDBTK_PATH_SEP
);
2256 if (Tcl_VarEval (interp
, "lappend auto_path ", lib
, NULL
) != TCL_OK
)
2258 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2263 gdbtk_file
= concat (lib
, "/main.tcl", (char *) NULL
);
2264 if (access (gdbtk_file
, R_OK
) == 0)
2267 Tcl_SetVar (interp
, "GDBTK_LIBRARY", lib
, 0);
2271 while ((lib
= strtok (NULL
, ":")) != NULL
);
2273 free (gdbtk_lib_tmp
);
2277 /* Try finding it with the auto path. */
2279 static const char script
[] ="\
2280 proc gdbtk_find_main {} {\n\
2281 global auto_path GDBTK_LIBRARY\n\
2282 foreach dir $auto_path {\n\
2283 set f [file join $dir main.tcl]\n\
2284 if {[file exists $f]} then {\n\
2285 set GDBTK_LIBRARY $dir\n\
2293 if (Tcl_GlobalEval (interp
, (char *) script
) != TCL_OK
)
2295 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2299 if (interp
->result
[0] != '\0')
2301 gdbtk_file
= xstrdup (interp
->result
);
2308 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2309 if (getenv("GDBTK_LIBRARY"))
2311 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
2312 fprintf_unfiltered (stderr
,
2313 "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
2317 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY
);
2318 fprintf_unfiltered (stderr
, "You might want to set GDBTK_LIBRARY\n");
2323 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
2324 prior to this point go to stdout/stderr. */
2326 fputs_unfiltered_hook
= gdbtk_fputs
;
2328 if (Tcl_EvalFile (interp
, gdbtk_file
) != TCL_OK
)
2332 /* Force errorInfo to be set up propertly. */
2333 Tcl_AddErrorInfo (interp
, "");
2335 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
2337 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2340 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
2342 fputs_unfiltered (msg
, gdb_stderr
);
2349 /* start-sanitize-ide */
2350 /* Don't do this until we have initialized. Otherwise, we may get a
2351 run command before we are ready for one. */
2352 if (ide_run_server_init (interp
, h
) != TCL_OK
)
2353 error ("ide_run_server_init failed: %s", interp
->result
);
2354 /* end-sanitize-ide */
2359 discard_cleanups (old_chain
);
2363 gdb_target_has_execution_command (clientData
, interp
, argc
, argv
)
2364 ClientData clientData
;
2371 if (target_has_execution
&& inferior_pid
!= 0)
2374 Tcl_SetIntObj (Tcl_GetObjResult (interp
), result
);
2378 /* gdb_load_info - returns information about the file about to be downloaded */
2381 gdb_load_info (clientData
, interp
, objc
, objv
)
2382 ClientData clientData
;
2385 Tcl_Obj
*CONST objv
[];
2388 struct cleanup
*old_cleanups
;
2394 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
2396 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
2397 if (loadfile_bfd
== NULL
)
2399 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Open failed", -1));
2402 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
2404 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
2406 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Bad Object File", -1));
2410 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
2412 if (s
->flags
& SEC_LOAD
)
2414 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
2417 ob
[0] = Tcl_NewStringObj((char *)bfd_get_section_name(loadfile_bfd
, s
), -1);
2418 ob
[1] = Tcl_NewLongObj ((long)size
);
2419 res
[i
++] = Tcl_NewListObj (2, ob
);
2424 Tcl_SetObjResult (interp
, Tcl_NewListObj (i
, res
));
2425 do_cleanups (old_cleanups
);
2431 gdbtk_load_hash (section
, num
)
2436 sprintf (buf
, "download_hash %s %ld", section
, num
);
2437 Tcl_Eval (interp
, buf
);
2438 return atoi (interp
->result
);
2441 /* gdb_get_vars_command -
2443 * Implements the "gdb_get_locals" and "gdb_get_args" tcl commands. This
2444 * function sets the Tcl interpreter's result to a list of variable names
2445 * depending on clientData. If clientData is one, the result is a list of
2446 * arguments; zero returns a list of locals -- all relative to the block
2447 * specified as an argument to the command. Valid commands include
2448 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
2452 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
2453 ClientData clientData
;
2456 Tcl_Obj
*CONST objv
[];
2459 struct symtabs_and_lines sals
;
2461 struct block
*block
;
2462 char **canonical
, *args
;
2463 int i
, nsyms
, arguments
;
2467 Tcl_AppendResult (interp
,
2468 "wrong # of args: should be \"",
2469 Tcl_GetStringFromObj (objv
[0], NULL
),
2470 " function:line|function|line|*addr\"");
2474 arguments
= (int) clientData
;
2475 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2476 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2477 if (sals
.nelts
== 0)
2479 Tcl_AppendResult (interp
,
2480 "error decoding line", NULL
);
2484 /* Initialize a list that will hold the results */
2485 result
= Tcl_NewListObj (0, NULL
);
2487 /* Resolve all line numbers to PC's */
2488 for (i
= 0; i
< sals
.nelts
; i
++)
2489 resolve_sal_pc (&sals
.sals
[i
]);
2491 block
= block_for_pc (sals
.sals
[0].pc
);
2494 nsyms
= BLOCK_NSYMS (block
);
2495 for (i
= 0; i
< nsyms
; i
++)
2497 sym
= BLOCK_SYM (block
, i
);
2498 switch (SYMBOL_CLASS (sym
)) {
2500 case LOC_UNDEF
: /* catches errors */
2501 case LOC_CONST
: /* constant */
2502 case LOC_STATIC
: /* static */
2503 case LOC_REGISTER
: /* register */
2504 case LOC_TYPEDEF
: /* local typedef */
2505 case LOC_LABEL
: /* local label */
2506 case LOC_BLOCK
: /* local function */
2507 case LOC_CONST_BYTES
: /* loc. byte seq. */
2508 case LOC_UNRESOLVED
: /* unresolved static */
2509 case LOC_OPTIMIZED_OUT
: /* optimized out */
2511 case LOC_ARG
: /* argument */
2512 case LOC_REF_ARG
: /* reference arg */
2513 case LOC_REGPARM
: /* register arg */
2514 case LOC_REGPARM_ADDR
: /* indirect register arg */
2515 case LOC_LOCAL_ARG
: /* stack arg */
2516 case LOC_BASEREG_ARG
: /* basereg arg */
2518 Tcl_ListObjAppendElement (interp
, result
,
2519 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2521 case LOC_LOCAL
: /* stack local */
2522 case LOC_BASEREG
: /* basereg local */
2524 Tcl_ListObjAppendElement (interp
, result
,
2525 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2529 if (BLOCK_FUNCTION (block
))
2532 block
= BLOCK_SUPERBLOCK (block
);
2535 Tcl_SetObjResult (interp
, result
);
2540 gdb_get_line_command (clientData
, interp
, objc
, objv
)
2541 ClientData clientData
;
2544 Tcl_Obj
*CONST objv
[];
2547 struct symtabs_and_lines sals
;
2548 char *args
, **canonical
;
2552 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2553 Tcl_GetStringFromObj (objv
[0], NULL
),
2558 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2559 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2560 if (sals
.nelts
== 1)
2562 Tcl_SetObjResult (interp
, Tcl_NewIntObj (sals
.sals
[0].line
));
2566 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2571 gdb_get_file_command (clientData
, interp
, objc
, objv
)
2572 ClientData clientData
;
2575 Tcl_Obj
*CONST objv
[];
2578 struct symtabs_and_lines sals
;
2579 char *args
, **canonical
;
2583 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2584 Tcl_GetStringFromObj (objv
[0], NULL
),
2589 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2590 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2591 if (sals
.nelts
== 1)
2593 Tcl_SetResult (interp
, sals
.sals
[0].symtab
->filename
, TCL_VOLATILE
);
2597 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2602 gdb_get_function_command (clientData
, interp
, objc
, objv
)
2603 ClientData clientData
;
2606 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 resolve_sal_pc (&sals
.sals
[0]);
2626 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
2627 if (function
!= NULL
)
2629 Tcl_SetResult (interp
, function
, TCL_VOLATILE
);
2634 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2639 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
2640 ClientData clientData
;
2643 Tcl_Obj
*CONST objv
[];
2645 struct symtab_and_line sal
;
2647 struct tracepoint
*tp
;
2648 struct action_line
*al
;
2649 Tcl_Obj
*list
, *action_list
;
2650 char *filename
, *funcname
;
2654 error ("wrong # args");
2656 Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
);
2658 ALL_TRACEPOINTS (tp
)
2659 if (tp
->number
== tpnum
)
2663 error ("Tracepoint #%d does not exist", tpnum
);
2665 list
= Tcl_NewListObj (0, NULL
);
2666 sal
= find_pc_line (tp
->address
, 0);
2667 filename
= symtab_to_filename (sal
.symtab
);
2668 if (filename
== NULL
)
2670 Tcl_ListObjAppendElement (interp
, list
,
2671 Tcl_NewStringObj (filename
, -1));
2672 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
2673 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (funcname
, -1));
2674 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (sal
.line
));
2675 sprintf (tmp
, "0x%08x", tp
->address
);
2676 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (tmp
, -1));
2677 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->enabled
));
2678 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->pass_count
));
2679 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->step_count
));
2680 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->thread
));
2681 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->hit_count
));
2683 /* Append a list of actions */
2684 action_list
= Tcl_NewListObj (0, NULL
);
2685 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
2687 Tcl_ListObjAppendElement (interp
, action_list
,
2688 Tcl_NewStringObj (al
->action
, -1));
2690 Tcl_ListObjAppendElement (interp
, list
, action_list
);
2692 Tcl_SetObjResult (interp
, list
);
2697 /* TclDebug (const char *fmt, ...) works just like printf() but */
2698 /* sends the output to the GDB TK debug window. */
2699 /* Not for normal use; just a convenient tool for debugging */
2701 #ifdef ANSI_PROTOTYPES
2702 TclDebug (const char *fmt
, ...)
2709 char buf
[512], *v
[2], *merge
;
2711 #ifdef ANSI_PROTOTYPES
2712 va_start (args
, fmt
);
2716 fmt
= va_arg (args
, char *);
2722 vsprintf (buf
, fmt
, args
);
2725 merge
= Tcl_Merge (2, v
);
2726 Tcl_Eval (interp
, merge
);
2731 /* Find the full pathname to a file, searching the symbol tables */
2734 gdb_find_file_command (clientData
, interp
, objc
, objv
)
2735 ClientData clientData
;
2738 Tcl_Obj
*CONST objv
[];
2740 char *filename
= NULL
;
2745 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
2749 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
2751 filename
= st
->fullname
;
2753 if (filename
== NULL
)
2754 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("", 0));
2756 Tcl_SetObjResult (interp
, Tcl_NewStringObj (filename
, -1));
2762 gdbtk_create_tracepoint (tp
)
2763 struct tracepoint
*tp
;
2765 tracepoint_notify (tp
, "create");
2769 gdbtk_delete_tracepoint (tp
)
2770 struct tracepoint
*tp
;
2772 tracepoint_notify (tp
, "delete");
2776 gdbtk_modify_tracepoint (tp
)
2777 struct tracepoint
*tp
;
2779 tracepoint_notify (tp
, "modify");
2783 tracepoint_notify(tp
, action
)
2784 struct tracepoint
*tp
;
2789 struct symtab_and_line sal
;
2792 /* We ensure that ACTION contains no special Tcl characters, so we
2794 sal
= find_pc_line (tp
->address
, 0);
2796 filename
= symtab_to_filename (sal
.symtab
);
2797 if (filename
== NULL
)
2799 sprintf (buf
, "gdbtk_tcl_tracepoint %s %d 0x%lx %d {%s}", action
, tp
->number
,
2800 (long)tp
->address
, sal
.line
, filename
);
2802 v
= Tcl_Eval (interp
, buf
);
2806 gdbtk_fputs (interp
->result
, gdb_stdout
);
2807 gdbtk_fputs ("\n", gdb_stdout
);
2811 /* returns -1 if not found, tracepoint # if found */
2813 tracepoint_exists (char * args
)
2815 struct tracepoint
*tp
;
2817 struct symtabs_and_lines sals
;
2821 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2822 if (sals
.nelts
== 1)
2824 resolve_sal_pc (&sals
.sals
[0]);
2825 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
2826 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
2829 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
2830 strcat (file
, sals
.sals
[0].symtab
->filename
);
2832 ALL_TRACEPOINTS (tp
)
2834 if (tp
->address
== sals
.sals
[0].pc
)
2835 result
= tp
->number
;
2836 else if (tp
->source_file
!= NULL
2837 && strcmp (tp
->source_file
, file
) == 0
2838 && sals
.sals
[0].line
== tp
->line_number
)
2840 result
= tp
->number
;
2850 gdb_actions_command (clientData
, interp
, objc
, objv
)
2851 ClientData clientData
;
2854 Tcl_Obj
*CONST objv
[];
2856 struct tracepoint
*tp
;
2858 int nactions
, i
, len
;
2859 char *number
, *args
, *action
;
2861 struct action_line
*next
= NULL
, *temp
;
2865 Tcl_AppendResult (interp
, "wrong # args: should be: \"",
2866 Tcl_GetStringFromObj (objv
[0], NULL
),
2867 " number actions\"");
2871 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
2872 tp
= get_tracepoint_by_number (&args
);
2875 Tcl_AppendResult (interp
, "Tracepoint \"", number
, "\" does not exist");
2879 /* Free any existing actions */
2880 if (tp
->actions
!= NULL
)
2885 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
2886 for (i
= 0; i
< nactions
; i
++)
2888 temp
= xmalloc (sizeof (struct action_line
));
2890 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
2891 temp
->action
= savestring (action
, len
);
2892 if (sscanf (temp
->action
, "while-stepping %d", &step_count
) !=0)
2893 tp
->step_count
= step_count
;
2910 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
2911 ClientData clientData
;
2914 Tcl_Obj
*CONST objv
[];
2920 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2921 Tcl_GetStringFromObj (objv
[0], NULL
),
2922 " function:line|function|line|*addr\"");
2926 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2928 Tcl_SetObjResult (interp
, Tcl_NewIntObj (tracepoint_exists (args
)));
2932 /* Return the prompt to the interpreter */
2934 gdb_prompt_command (clientData
, interp
, objc
, objv
)
2935 ClientData clientData
;
2938 Tcl_Obj
*CONST objv
[];
2940 Tcl_SetResult (interp
, get_prompt (), TCL_VOLATILE
);
2944 /* return a list of all tracepoint numbers in interpreter */
2946 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
2947 ClientData clientData
;
2950 Tcl_Obj
*CONST objv
[];
2953 struct tracepoint
*tp
;
2955 list
= Tcl_NewListObj (0, NULL
);
2957 ALL_TRACEPOINTS (tp
)
2958 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->number
));
2960 Tcl_SetObjResult (interp
, list
);
2965 /* This hook is called whenever we are ready to load a symbol file so that
2966 the UI can notify the user... */
2968 gdbtk_pre_add_symbol (name
)
2973 v
[0] = "gdbtk_tcl_pre_add_symbol";
2975 merge
= Tcl_Merge (2, v
);
2976 Tcl_Eval (interp
, merge
);
2980 /* This hook is called whenever we finish loading a symbol file. */
2982 gdbtk_post_add_symbol ()
2984 Tcl_Eval (interp
, "gdbtk_tcl_post_add_symbol");
2990 gdbtk_print_frame_info (s
, line
, stopline
, noerror
)
2996 current_source_symtab
= s
;
2997 current_source_line
= line
;
3001 /* The lookup_symtab() in symtab.c doesn't work correctly */
3002 /* It will not work will full pathnames and if multiple */
3003 /* source files have the same basename, it will return */
3004 /* the first one instead of the correct one. This version */
3005 /* also always makes sure symtab->fullname is set. */
3007 static struct symtab
*
3008 full_lookup_symtab(file
)
3012 struct objfile
*objfile
;
3013 char *bfile
, *fullname
;
3014 struct partial_symtab
*pt
;
3019 /* first try a direct lookup */
3020 st
= lookup_symtab (file
);
3024 symtab_to_filename(st
);
3028 /* if the direct approach failed, try */
3029 /* looking up the basename and checking */
3030 /* all matches with the fullname */
3031 bfile
= basename (file
);
3032 ALL_SYMTABS (objfile
, st
)
3034 if (!strcmp (bfile
, basename(st
->filename
)))
3037 fullname
= symtab_to_filename (st
);
3039 fullname
= st
->fullname
;
3041 if (!strcmp (file
, fullname
))
3046 /* still no luck? look at psymtabs */
3047 ALL_PSYMTABS (objfile
, pt
)
3049 if (!strcmp (bfile
, basename(pt
->filename
)))
3051 st
= PSYMTAB_TO_SYMTAB (pt
);
3054 fullname
= symtab_to_filename (st
);
3055 if (!strcmp (file
, fullname
))
3064 /* gdb_loadfile loads a c source file into a text widget. */
3066 /* LTABLE_SIZE is the number of bytes to allocate for the */
3067 /* line table. Its size limits the maximum number of lines */
3068 /* in a file to 8 * LTABLE_SIZE. This memory is freed after */
3069 /* the file is loaded, so it is OK to make this very large. */
3070 /* Additional memory will be allocated if needed. */
3071 #define LTABLE_SIZE 20000
3074 gdb_loadfile (clientData
, interp
, objc
, objv
)
3075 ClientData clientData
;
3078 Tcl_Obj
*CONST objv
[];
3080 char *file
, *widget
, *line
, *buf
, msg
[128];
3081 int linenumbers
, ln
, anum
, lnum
, ltable_size
;
3082 Tcl_Obj
*a
[2], *b
[2], *cmd
;
3085 struct symtab
*symtab
;
3086 struct linetable_entry
*le
;
3090 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
3094 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
3095 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
3096 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
3098 if ((fp
= fopen ( file
, "r" )) == NULL
)
3101 symtab
= full_lookup_symtab (file
);
3104 sprintf(msg
, "File not found");
3105 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3110 /* Source linenumbers don't appear to be in order, and a sort is */
3111 /* too slow so the fastest solution is just to allocate a huge */
3112 /* array and set the array entry for each linenumber */
3114 ltable_size
= LTABLE_SIZE
;
3115 ltable
= (char *)malloc (LTABLE_SIZE
);
3118 sprintf(msg
, "Out of memory.");
3119 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3124 memset (ltable
, 0, LTABLE_SIZE
);
3126 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
3128 le
= symtab
->linetable
->item
;
3129 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
3131 lnum
= le
->line
>> 3;
3132 if (lnum
>= ltable_size
)
3135 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
3136 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
3138 if (new_ltable
== NULL
)
3140 sprintf(msg
, "Out of memory.");
3141 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3146 ltable
= new_ltable
;
3148 ltable
[lnum
] |= 1 << (le
->line
% 8);
3152 /* create an object with enough space, then grab its */
3153 /* buffer and sprintf directly into it. */
3154 a
[0] = Tcl_NewStringObj (ltable
, 1024);
3155 a
[1] = Tcl_NewListObj(0,NULL
);
3157 b
[0] = Tcl_NewStringObj (ltable
,1024);
3158 b
[1] = Tcl_NewStringObj ("source_tag", -1);
3159 Tcl_IncrRefCount (b
[0]);
3160 Tcl_IncrRefCount (b
[1]);
3161 line
= b
[0]->bytes
+ 1;
3162 strcpy(b
[0]->bytes
,"\t");
3165 while (fgets (line
, 980, fp
))
3169 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3170 a
[0]->length
= sprintf (buf
,"%s insert end {-\t%d} break_tag", widget
, ln
);
3172 a
[0]->length
= sprintf (buf
,"%s insert end { \t%d} \"\"", widget
, ln
);
3176 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3177 a
[0]->length
= sprintf (buf
,"%s insert end {-\t} break_tag", widget
);
3179 a
[0]->length
= sprintf (buf
,"%s insert end { \t} \"\"", widget
);
3181 b
[0]->length
= strlen(b
[0]->bytes
);
3182 Tcl_SetListObj(a
[1],2,b
);
3183 cmd
= Tcl_ConcatObj(2,a
);
3184 Tcl_EvalObj (interp
, cmd
);
3185 Tcl_DecrRefCount (cmd
);
3188 Tcl_DecrRefCount (b
[0]);
3189 Tcl_DecrRefCount (b
[0]);
3190 Tcl_DecrRefCount (b
[1]);
3191 Tcl_DecrRefCount (b
[1]);
3197 /* at some point make these static in breakpoint.c and move GUI code there */
3198 extern struct breakpoint
*set_raw_breakpoint (struct symtab_and_line sal
);
3199 extern void set_breakpoint_count (int);
3200 extern int breakpoint_count
;
3202 /* set a breakpoint by source file and line number */
3203 /* flags are as follows: */
3204 /* least significant 2 bits are disposition, rest is */
3205 /* type (normally 0).
3208 bp_breakpoint, Normal breakpoint
3209 bp_hardware_breakpoint, Hardware assisted breakpoint
3212 Disposition of breakpoint. Ie: what to do after hitting it.
3215 del_at_next_stop, Delete at next stop, whether hit or not
3217 donttouch Leave it alone
3222 gdb_set_bp (clientData
, interp
, objc
, objv
)
3223 ClientData clientData
;
3226 Tcl_Obj
*CONST objv
[];
3229 struct symtab_and_line sal
;
3230 int line
, flags
, ret
;
3231 struct breakpoint
*b
;
3233 Tcl_Obj
*a
[5], *cmd
;
3237 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
3241 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
3242 if (sal
.symtab
== NULL
)
3245 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
3248 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
3252 sal
.pc
= find_line_pc (sal
.symtab
, sal
.line
);
3256 sal
.section
= find_pc_overlay (sal
.pc
);
3257 b
= set_raw_breakpoint (sal
);
3258 set_breakpoint_count (breakpoint_count
+ 1);
3259 b
->number
= breakpoint_count
;
3260 b
->type
= flags
>> 2;
3261 b
->disposition
= flags
& 3;
3263 /* FIXME: this won't work for duplicate basenames! */
3264 sprintf (buf
, "%s:%d", basename(Tcl_GetStringFromObj( objv
[1], NULL
)), line
);
3265 b
->addr_string
= strsave (buf
);
3267 /* now send notification command back to GUI */
3268 sprintf (buf
, "0x%x", sal
.pc
);
3269 a
[0] = Tcl_NewStringObj ("gdbtk_tcl_breakpoint create", -1);
3270 a
[1] = Tcl_NewIntObj (b
->number
);
3271 a
[2] = Tcl_NewStringObj (buf
, -1);
3273 a
[4] = Tcl_NewListObj (1,&objv
[1]);
3274 cmd
= Tcl_ConcatObj(5,a
);
3275 ret
= Tcl_EvalObj (interp
, cmd
);
3276 Tcl_DecrRefCount (cmd
);
3281 /* The whole timer idea is an easy one, but POSIX does not appear to have
3282 some sort of interval timer requirement. Consequently, we cannot rely
3283 on cygwin32 to always deliver the timer's signal. This is especially
3284 painful given that all serial I/O will block the timer right now. */
3286 gdbtk_annotate_starting ()
3288 /* TclDebug ("### STARTING ###"); */
3289 gdbtk_start_timer ();
3293 gdbtk_annotate_stopped ()
3295 /* TclDebug ("### STOPPED ###"); */
3296 gdbtk_stop_timer ();
3300 gdbtk_annotate_exited ()
3302 /* TclDebug ("### EXITED ###"); */
3303 gdbtk_stop_timer ();
3307 gdbtk_annotate_signalled ()
3309 /* TclDebug ("### SIGNALLED ###"); */
3310 gdbtk_stop_timer ();
3314 /* Come here during initialize_all_files () */
3317 _initialize_gdbtk ()
3321 /* Tell the rest of the world that Gdbtk is now set up. */
3323 init_ui_hook
= gdbtk_init
;