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;
93 int gdbtk_load_hash
PARAMS ((char *, unsigned long));
94 int (*ui_load_progress_hook
) PARAMS ((char *, unsigned long));
95 void (*pre_add_symbol_hook
) PARAMS ((char *));
96 void (*post_add_symbol_hook
) PARAMS ((void));
98 /* This is a disgusting hack. Unfortunately, the UI will lock up if we
99 are doing something like blocking in a system call, waiting for serial I/O,
102 This hook should be used whenever we might block. This means adding appropriate
103 timeouts to code and what not to allow this hook to be called. */
104 void (*ui_loop_hook
) PARAMS ((int));
106 char * get_prompt
PARAMS ((void));
108 static void null_routine
PARAMS ((int));
109 static void gdbtk_flush
PARAMS ((FILE *));
110 static void gdbtk_fputs
PARAMS ((const char *, FILE *));
111 static int gdbtk_query
PARAMS ((const char *, va_list));
112 static char *gdbtk_readline
PARAMS ((char *));
113 static void gdbtk_init
PARAMS ((char *));
114 static void tk_command_loop
PARAMS ((void));
115 static void gdbtk_call_command
PARAMS ((struct cmd_list_element
*, char *, int));
116 static int gdbtk_wait
PARAMS ((int, struct target_waitstatus
*));
117 static void x_event
PARAMS ((int));
118 static void gdbtk_interactive
PARAMS ((void));
119 static void cleanup_init
PARAMS ((int));
120 static void tk_command
PARAMS ((char *, int));
121 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
122 static int compare_lines
PARAMS ((const PTR
, const PTR
));
123 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
124 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
125 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
126 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
127 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
128 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
129 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
130 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
131 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
132 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
133 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
134 static void gdbtk_readline_end
PARAMS ((void));
135 static void pc_changed
PARAMS ((void));
136 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
137 static void register_changed_p
PARAMS ((int, void *));
138 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
139 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
140 static void breakpoint_notify
PARAMS ((struct breakpoint
*, const char *));
141 static void gdbtk_create_breakpoint
PARAMS ((struct breakpoint
*));
142 static void gdbtk_delete_breakpoint
PARAMS ((struct breakpoint
*));
143 static void gdbtk_modify_breakpoint
PARAMS ((struct breakpoint
*));
144 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
145 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
146 static int map_arg_registers
PARAMS ((int, char *[], void (*) (int, void *), void *));
147 static void get_register_name
PARAMS ((int, void *));
148 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
149 static void get_register
PARAMS ((int, void *));
150 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
151 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
152 void TclDebug
PARAMS ((const char *fmt
, ...));
153 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
154 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
155 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
156 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
157 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
158 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
159 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
160 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
161 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
162 static char *find_file_in_dir
PARAMS ((char *));
163 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
164 static void gdbtk_create_tracepoint
PARAMS ((struct tracepoint
*));
165 static void gdbtk_delete_tracepoint
PARAMS ((struct tracepoint
*));
166 static void gdbtk_modify_tracepoint
PARAMS ((struct tracepoint
*));
167 static void tracepoint_notify
PARAMS ((struct tracepoint
*, const char *));
168 static void gdbtk_print_frame_info
PARAMS ((struct symtab
*, int, int, int));
169 void gdbtk_pre_add_symbol
PARAMS ((char *));
170 void gdbtk_post_add_symbol
PARAMS ((void));
171 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
172 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
173 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
174 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
175 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
177 static void gdbtk_annotate_starting
PARAMS ((void));
178 static void gdbtk_annotate_stopped
PARAMS ((void));
179 static void gdbtk_annotate_signalled
PARAMS ((void));
180 static void gdbtk_annotate_exited
PARAMS ((void));
183 /* Handle for TCL interpreter */
184 static Tcl_Interp
*interp
= NULL
;
187 static int x_fd
; /* X network socket */
192 /* On Windows we use timer interrupts when gdb might otherwise hang
193 for a long time. See the comment above gdbtk_start_timer. This
194 variable is true when timer interrupts are being used. */
196 static int gdbtk_timer_going
= 0;
198 static void gdbtk_start_timer
PARAMS ((void));
199 static void gdbtk_stop_timer
PARAMS ((void));
203 /* This variable is true when the inferior is running. Although it's
204 possible to disable most input from widgets and thus prevent
205 attempts to do anything while the inferior is running, any commands
206 that get through - even a simple memory read - are Very Bad, and
207 may cause GDB to crash or behave strangely. So, this variable
208 provides an extra layer of defense. */
210 static int running_now
;
212 /* This variable determines where memory used for disassembly is read from.
213 If > 0, then disassembly comes from the exec file rather than the
214 target (which might be at the other end of a slow serial link). If
215 == 0 then disassembly comes from target. If < 0 disassembly is
216 automatically switched to the target if it's an inferior process,
217 otherwise the exec file is used. */
219 static int disassemble_from_exec
= -1;
223 /* Supply malloc calls for tcl/tk. We do not want to do this on
224 Windows, because Tcl_Alloc is probably in a DLL which will not call
225 the mmalloc routines. */
231 return xmalloc (size
);
235 Tcl_Realloc (ptr
, size
)
239 return xrealloc (ptr
, size
);
249 #endif /* ! _WIN32 */
259 /* On Windows, if we hold a file open, other programs can't write to
260 it. In particular, we don't want to hold the executable open,
261 because it will mean that people have to get out of the debugging
262 session in order to remake their program. So we close it, although
263 this will cost us if and when we need to reopen it. */
273 bfd_cache_close (o
->obfd
);
276 if (exec_bfd
!= NULL
)
277 bfd_cache_close (exec_bfd
);
282 /* The following routines deal with stdout/stderr data, which is created by
283 {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the
284 lowest level of these routines and capture all output from the rest of GDB.
285 Normally they present their data to tcl via callbacks to the following tcl
286 routines: gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush. These
287 in turn call tk routines to update the display.
289 Under some circumstances, you may want to collect the output so that it can
290 be returned as the value of a tcl procedure. This can be done by
291 surrounding the output routines with calls to start_saving_output and
292 finish_saving_output. The saved data can then be retrieved with
293 get_saved_output (but this must be done before the call to
294 finish_saving_output). */
296 /* Dynamic string for output. */
298 static Tcl_DString
*result_ptr
;
300 /* Dynamic string for stderr. This is only used if result_ptr is
303 static Tcl_DString
*error_string_ptr
;
310 /* Force immediate screen update */
312 Tcl_VarEval (interp
, "gdbtk_tcl_flush", NULL
);
317 gdbtk_fputs (ptr
, stream
)
322 Tcl_DStringAppend (result_ptr
, (char *) ptr
, -1);
323 else if (error_string_ptr
!= NULL
&& stream
== gdb_stderr
)
324 Tcl_DStringAppend (error_string_ptr
, (char *) ptr
, -1);
329 Tcl_DStringInit (&str
);
331 Tcl_DStringAppend (&str
, "gdbtk_tcl_fputs", -1);
332 Tcl_DStringAppendElement (&str
, (char *)ptr
);
334 Tcl_Eval (interp
, Tcl_DStringValue (&str
));
335 Tcl_DStringFree (&str
);
340 gdbtk_query (query
, args
)
344 char buf
[200], *merge
[2];
348 vsprintf (buf
, query
, args
);
349 merge
[0] = "gdbtk_tcl_query";
351 command
= Tcl_Merge (2, merge
);
352 Tcl_Eval (interp
, command
);
355 val
= atol (interp
->result
);
361 #ifdef ANSI_PROTOTYPES
362 gdbtk_readline_begin (char *format
, ...)
364 gdbtk_readline_begin (va_alist
)
369 char buf
[200], *merge
[2];
372 #ifdef ANSI_PROTOTYPES
373 va_start (args
, format
);
377 format
= va_arg (args
, char *);
380 vsprintf (buf
, format
, args
);
381 merge
[0] = "gdbtk_tcl_readline_begin";
383 command
= Tcl_Merge (2, merge
);
384 Tcl_Eval (interp
, command
);
389 gdbtk_readline (prompt
)
400 merge
[0] = "gdbtk_tcl_readline";
402 command
= Tcl_Merge (2, merge
);
403 result
= Tcl_Eval (interp
, command
);
405 if (result
== TCL_OK
)
407 return (strdup (interp
-> result
));
411 gdbtk_fputs (interp
-> result
, gdb_stdout
);
412 gdbtk_fputs ("\n", gdb_stdout
);
418 gdbtk_readline_end ()
420 Tcl_Eval (interp
, "gdbtk_tcl_readline_end");
426 Tcl_Eval (interp
, "gdbtk_pc_changed");
431 #ifdef ANSI_PROTOTYPES
432 dsprintf_append_element (Tcl_DString
*dsp
, char *format
, ...)
434 dsprintf_append_element (va_alist
)
441 #ifdef ANSI_PROTOTYPES
442 va_start (args
, format
);
448 dsp
= va_arg (args
, Tcl_DString
*);
449 format
= va_arg (args
, char *);
452 vsprintf (buf
, format
, args
);
454 Tcl_DStringAppendElement (dsp
, buf
);
458 gdb_path_conv (clientData
, interp
, argc
, argv
)
459 ClientData clientData
;
465 char pathname
[256], *ptr
;
467 error ("wrong # args");
468 cygwin32_conv_to_full_win32_path (argv
[1], pathname
);
469 for (ptr
= pathname
; *ptr
; ptr
++)
475 char *pathname
= argv
[1];
477 Tcl_DStringAppend (result_ptr
, pathname
, strlen(pathname
));
482 gdb_get_breakpoint_list (clientData
, interp
, argc
, argv
)
483 ClientData clientData
;
488 struct breakpoint
*b
;
489 extern struct breakpoint
*breakpoint_chain
;
492 error ("wrong # args");
494 for (b
= breakpoint_chain
; b
; b
= b
->next
)
495 if (b
->type
== bp_breakpoint
)
496 dsprintf_append_element (result_ptr
, "%d", b
->number
);
502 gdb_get_breakpoint_info (clientData
, interp
, argc
, argv
)
503 ClientData clientData
;
508 struct symtab_and_line sal
;
509 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
510 "finish", "watchpoint", "hardware watchpoint",
511 "read watchpoint", "access watchpoint",
512 "longjmp", "longjmp resume", "step resume",
513 "through sigtramp", "watchpoint scope",
515 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
516 struct command_line
*cmd
;
518 struct breakpoint
*b
;
519 extern struct breakpoint
*breakpoint_chain
;
520 char *funcname
, *fname
, *filename
;
523 error ("wrong # args");
525 bpnum
= atoi (argv
[1]);
527 for (b
= breakpoint_chain
; b
; b
= b
->next
)
528 if (b
->number
== bpnum
)
531 if (!b
|| b
->type
!= bp_breakpoint
)
532 error ("Breakpoint #%d does not exist", bpnum
);
534 sal
= find_pc_line (b
->address
, 0);
536 filename
= symtab_to_filename (sal
.symtab
);
537 if (filename
== NULL
)
539 Tcl_DStringAppendElement (result_ptr
, filename
);
541 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
542 fname
= cplus_demangle (funcname
, 0);
545 Tcl_DStringAppendElement (result_ptr
, fname
);
549 Tcl_DStringAppendElement (result_ptr
, funcname
);
550 dsprintf_append_element (result_ptr
, "%d", b
->line_number
);
551 dsprintf_append_element (result_ptr
, "0x%lx", b
->address
);
552 Tcl_DStringAppendElement (result_ptr
, bptypes
[b
->type
]);
553 Tcl_DStringAppendElement (result_ptr
, b
->enable
== enabled
? "1" : "0");
554 Tcl_DStringAppendElement (result_ptr
, bpdisp
[b
->disposition
]);
555 dsprintf_append_element (result_ptr
, "%d", b
->ignore_count
);
557 Tcl_DStringStartSublist (result_ptr
);
558 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
559 Tcl_DStringAppendElement (result_ptr
, cmd
->line
);
560 Tcl_DStringEndSublist (result_ptr
);
562 Tcl_DStringAppendElement (result_ptr
, b
->cond_string
);
564 dsprintf_append_element (result_ptr
, "%d", b
->thread
);
565 dsprintf_append_element (result_ptr
, "%d", b
->hit_count
);
571 breakpoint_notify(b
, action
)
572 struct breakpoint
*b
;
577 struct symtab_and_line sal
;
580 if (b
->type
!= bp_breakpoint
)
583 /* We ensure that ACTION contains no special Tcl characters, so we
585 sal
= find_pc_line (b
->address
, 0);
586 filename
= symtab_to_filename (sal
.symtab
);
587 if (filename
== NULL
)
590 sprintf (buf
, "gdbtk_tcl_breakpoint %s %d 0x%lx %d {%s}", action
, b
->number
,
591 (long)b
->address
, b
->line_number
, filename
);
593 v
= Tcl_Eval (interp
, buf
);
597 gdbtk_fputs (interp
->result
, gdb_stdout
);
598 gdbtk_fputs ("\n", gdb_stdout
);
603 gdbtk_create_breakpoint(b
)
604 struct breakpoint
*b
;
606 breakpoint_notify (b
, "create");
610 gdbtk_delete_breakpoint(b
)
611 struct breakpoint
*b
;
613 breakpoint_notify (b
, "delete");
617 gdbtk_modify_breakpoint(b
)
618 struct breakpoint
*b
;
620 breakpoint_notify (b
, "modify");
623 /* This implements the TCL command `gdb_loc', which returns a list */
624 /* consisting of the following: */
625 /* basename, function name, filename, line number, address, current pc */
628 gdb_loc (clientData
, interp
, argc
, argv
)
629 ClientData clientData
;
635 struct symtab_and_line sal
;
636 char *funcname
, *fname
;
639 if (!have_full_symbols () && !have_partial_symbols ())
641 Tcl_SetResult (interp
, "No symbol table is loaded", TCL_STATIC
);
647 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
649 /* Note - this next line is not correct on all architectures. */
650 /* For a graphical debugged we really want to highlight the */
651 /* assembly line that called the next function on the stack. */
652 /* Many architectures have the next instruction saved as the */
653 /* pc on the stack, so what happens is the next instruction is hughlighted. */
655 pc
= selected_frame
->pc
;
656 sal
= find_pc_line (selected_frame
->pc
,
657 selected_frame
->next
!= NULL
658 && !selected_frame
->next
->signal_handler_caller
659 && !frame_in_dummy (selected_frame
->next
));
664 sal
= find_pc_line (stop_pc
, 0);
669 struct symtabs_and_lines sals
;
672 sals
= decode_line_spec (argv
[1], 1);
679 error ("Ambiguous line spec");
682 error ("wrong # args");
686 Tcl_DStringAppendElement (result_ptr
, sal
.symtab
->filename
);
688 Tcl_DStringAppendElement (result_ptr
, "");
690 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
691 fname
= cplus_demangle (funcname
, 0);
694 Tcl_DStringAppendElement (result_ptr
, fname
);
698 Tcl_DStringAppendElement (result_ptr
, funcname
);
699 filename
= symtab_to_filename (sal
.symtab
);
700 if (filename
== NULL
)
703 Tcl_DStringAppendElement (result_ptr
, filename
);
704 dsprintf_append_element (result_ptr
, "%d", sal
.line
); /* line number */
705 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
706 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
710 /* This implements the TCL command `gdb_eval'. */
713 gdb_eval (clientData
, interp
, argc
, argv
)
714 ClientData clientData
;
719 struct expression
*expr
;
720 struct cleanup
*old_chain
;
724 error ("wrong # args");
726 expr
= parse_expression (argv
[1]);
728 old_chain
= make_cleanup (free_current_contents
, &expr
);
730 val
= evaluate_expression (expr
);
732 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
733 gdb_stdout
, 0, 0, 0, 0);
735 do_cleanups (old_chain
);
740 /* gdb_get_mem addr form size num aschar*/
741 /* dump a block of memory */
742 /* addr: address of data to dump */
743 /* form: a char indicating format */
744 /* size: size of each element; 1,2,4, or 8 bytes*/
745 /* num: the number of bytes to read */
746 /* acshar: an optional ascii character to use in ASCII dump */
747 /* returns a list of elements followed by an optional */
751 gdb_get_mem (clientData
, interp
, argc
, argv
)
752 ClientData clientData
;
757 int size
, asize
, i
, j
, bc
;
759 int nbytes
, rnum
, bpr
;
760 char format
, c
, *ptr
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
761 struct type
*val_type
;
763 if (argc
< 6 || argc
> 7)
765 interp
->result
= "addr format size bytes bytes_per_row ?ascii_char?";
769 size
= (int)strtoul(argv
[3],(char **)NULL
,0);
770 nbytes
= (int)strtoul(argv
[4],(char **)NULL
,0);
771 bpr
= (int)strtoul(argv
[5],(char **)NULL
,0);
772 if (nbytes
<= 0 || bpr
<= 0 || size
<= 0)
774 interp
->result
= "Invalid number of bytes.";
778 addr
= (CORE_ADDR
)strtoul(argv
[1],(char **)NULL
,0);
780 mbuf
= (char *)malloc (nbytes
+32);
783 interp
->result
= "Out of memory.";
786 memset (mbuf
, 0, nbytes
+32);
789 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
798 val_type
= builtin_type_char
;
802 val_type
= builtin_type_short
;
806 val_type
= builtin_type_int
;
810 val_type
= builtin_type_long_long
;
814 val_type
= builtin_type_char
;
818 bc
= 0; /* count of bytes in a row */
819 buff
[0] = '"'; /* buffer for ascii dump */
820 bptr
= &buff
[1]; /* pointer for ascii dump */
822 for (i
=0; i
< nbytes
; i
+= size
)
826 fputs_unfiltered ("N/A ", gdb_stdout
);
828 for ( j
= 0; j
< size
; j
++)
833 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
834 fputs_unfiltered (" ", gdb_stdout
);
837 for ( j
= 0; j
< size
; j
++)
840 if (c
< 32 || c
> 126)
852 if (aschar
&& (bc
>= bpr
))
854 /* end of row. print it and reset variables */
859 fputs_unfiltered (buff
, gdb_stdout
);
869 map_arg_registers (argc
, argv
, func
, argp
)
872 void (*func
) PARAMS ((int regnum
, void *argp
));
877 /* Note that the test for a valid register must include checking the
878 reg_names array because NUM_REGS may be allocated for the union of the
879 register sets within a family of related processors. In this case, the
880 trailing entries of reg_names will change depending upon the particular
881 processor being debugged. */
883 if (argc
== 0) /* No args, just do all the regs */
887 && reg_names
[regnum
] != NULL
888 && *reg_names
[regnum
] != '\000';
895 /* Else, list of register #s, just do listed regs */
896 for (; argc
> 0; argc
--, argv
++)
898 regnum
= atoi (*argv
);
902 && reg_names
[regnum
] != NULL
903 && *reg_names
[regnum
] != '\000')
906 error ("bad register number");
913 get_register_name (regnum
, argp
)
915 void *argp
; /* Ignored */
917 Tcl_DStringAppendElement (result_ptr
, reg_names
[regnum
]);
920 /* This implements the TCL command `gdb_regnames', which returns a list of
921 all of the register names. */
924 gdb_regnames (clientData
, interp
, argc
, argv
)
925 ClientData clientData
;
933 return map_arg_registers (argc
, argv
, get_register_name
, NULL
);
936 #ifndef REGISTER_CONVERTIBLE
937 #define REGISTER_CONVERTIBLE(x) (0 != 0)
940 #ifndef REGISTER_CONVERT_TO_VIRTUAL
941 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
944 #ifndef INVALID_FLOAT
945 #define INVALID_FLOAT(x, y) (0 != 0)
949 get_register (regnum
, fp
)
953 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
954 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
955 int format
= (int)fp
;
960 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
962 Tcl_DStringAppendElement (result_ptr
, "Optimized out");
966 /* Convert raw data to virtual format if necessary. */
968 if (REGISTER_CONVERTIBLE (regnum
))
970 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
971 raw_buffer
, virtual_buffer
);
974 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
979 printf_filtered ("0x");
980 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
982 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
983 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
984 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
988 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
989 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
991 Tcl_DStringAppend (result_ptr
, " ", -1);
995 get_pc_register (clientData
, interp
, argc
, argv
)
996 ClientData clientData
;
1001 sprintf(interp
->result
,"0x%llx",(long long)read_register(PC_REGNUM
));
1006 gdb_fetch_registers (clientData
, interp
, argc
, argv
)
1007 ClientData clientData
;
1015 error ("wrong # args");
1021 return map_arg_registers (argc
, argv
, get_register
, (void *) format
);
1024 /* This contains the previous values of the registers, since the last call to
1025 gdb_changed_register_list. */
1027 static char old_regs
[REGISTER_BYTES
];
1030 register_changed_p (regnum
, argp
)
1032 void *argp
; /* Ignored */
1034 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1036 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1039 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1040 REGISTER_RAW_SIZE (regnum
)) == 0)
1043 /* Found a changed register. Save new value and return its number. */
1045 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1046 REGISTER_RAW_SIZE (regnum
));
1048 dsprintf_append_element (result_ptr
, "%d", regnum
);
1052 gdb_changed_register_list (clientData
, interp
, argc
, argv
)
1053 ClientData clientData
;
1061 return map_arg_registers (argc
, argv
, register_changed_p
, NULL
);
1064 /* This implements the tcl command "gdb_immediate", which does exactly
1065 the same thing as gdb_cmd, except NONE of its outut is buffered. */
1067 gdb_immediate_command (clientData
, interp
, argc
, argv
)
1068 ClientData clientData
;
1073 Tcl_DString
*save_ptr
= NULL
;
1076 error ("wrong # args");
1081 Tcl_DStringAppend (result_ptr
, "", -1);
1082 save_ptr
= result_ptr
;
1085 execute_command (argv
[1], 1);
1087 bpstat_do_actions (&stop_bpstat
);
1089 result_ptr
= save_ptr
;
1094 /* This implements the TCL command `gdb_cmd', which sends its argument into
1095 the GDB command scanner. */
1098 gdb_cmd (clientData
, interp
, argc
, argv
)
1099 ClientData clientData
;
1104 Tcl_DString
*save_ptr
= NULL
;
1107 error ("wrong # args");
1112 /* for the load instruction (and possibly others later) we
1113 set result_ptr to NULL so gdbtk_fputs() will not buffer
1114 all the data until the command is finished. */
1116 if (strncmp ("load ", argv
[1], 5) == 0
1117 || strncmp ("while ", argv
[1], 6) == 0)
1119 Tcl_DStringAppend (result_ptr
, "", -1);
1120 save_ptr
= result_ptr
;
1122 load_in_progress
= 1;
1124 /* On Windows, use timer interrupts so that the user can cancel
1125 the download. FIXME: We may have to do something on other
1128 gdbtk_start_timer ();
1132 execute_command (argv
[1], 1);
1135 if (load_in_progress
)
1136 gdbtk_stop_timer ();
1139 load_in_progress
= 0;
1140 bpstat_do_actions (&stop_bpstat
);
1143 result_ptr
= save_ptr
;
1148 /* Client of call_wrapper - this routine performs the actual call to
1149 the client function. */
1151 struct wrapped_call_args
1162 struct wrapped_call_args
*args
;
1164 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->argc
, args
->argv
);
1168 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
1169 handles cleanups, and calls to return_to_top_level (usually via error).
1170 This is necessary in order to prevent a longjmp out of the bowels of Tk,
1171 possibly leaving things in a bad state. Since this routine can be called
1172 recursively, it needs to save and restore the contents of the jmp_buf as
1176 call_wrapper (clientData
, interp
, argc
, argv
)
1177 ClientData clientData
;
1182 struct wrapped_call_args wrapped_args
;
1183 Tcl_DString result
, *old_result_ptr
;
1184 Tcl_DString error_string
, *old_error_string_ptr
;
1186 Tcl_DStringInit (&result
);
1187 old_result_ptr
= result_ptr
;
1188 result_ptr
= &result
;
1190 Tcl_DStringInit (&error_string
);
1191 old_error_string_ptr
= error_string_ptr
;
1192 error_string_ptr
= &error_string
;
1194 wrapped_args
.func
= (Tcl_CmdProc
*)clientData
;
1195 wrapped_args
.interp
= interp
;
1196 wrapped_args
.argc
= argc
;
1197 wrapped_args
.argv
= argv
;
1198 wrapped_args
.val
= 0;
1200 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
1202 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
1205 /* Make sure the timer interrupts are turned off. */
1206 if (gdbtk_timer_going
)
1207 gdbtk_stop_timer ();
1210 gdb_flush (gdb_stderr
); /* Flush error output */
1211 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
1213 /* In case of an error, we may need to force the GUI into idle
1214 mode because gdbtk_call_command may have bombed out while in
1215 the command routine. */
1218 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1221 /* do not suppress any errors -- a remote target could have errored */
1222 load_in_progress
= 0;
1224 if (Tcl_DStringLength (&error_string
) == 0)
1226 Tcl_DStringResult (interp
, &result
);
1227 Tcl_DStringFree (&error_string
);
1229 else if (Tcl_DStringLength (&result
) == 0)
1231 Tcl_DStringResult (interp
, &error_string
);
1232 Tcl_DStringFree (&result
);
1233 Tcl_DStringFree (&error_string
);
1237 Tcl_ResetResult (interp
);
1238 Tcl_AppendResult (interp
, Tcl_DStringValue (&result
),
1239 Tcl_DStringValue (&error_string
), (char *) NULL
);
1240 Tcl_DStringFree (&result
);
1241 Tcl_DStringFree (&error_string
);
1244 result_ptr
= old_result_ptr
;
1245 error_string_ptr
= old_error_string_ptr
;
1251 return wrapped_args
.val
;
1255 comp_files (file1
, file2
)
1256 const char *file1
[], *file2
[];
1258 return strcmp(*file1
,*file2
);
1262 gdb_listfiles (clientData
, interp
, objc
, objv
)
1263 ClientData clientData
;
1266 Tcl_Obj
*CONST objv
[];
1268 struct objfile
*objfile
;
1269 struct partial_symtab
*psymtab
;
1270 struct symtab
*symtab
;
1271 char *lastfile
, *pathname
, *files
[1000];
1272 int i
, numfiles
= 0, len
= 0;
1277 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1281 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1283 mylist
= Tcl_NewListObj (0, NULL
);
1285 ALL_PSYMTABS (objfile
, psymtab
)
1289 if (psymtab
->filename
)
1290 files
[numfiles
++] = basename(psymtab
->filename
);
1292 else if (!strcmp(psymtab
->filename
,basename(psymtab
->filename
))
1293 || !strncmp(pathname
,psymtab
->filename
,len
))
1294 if (psymtab
->filename
)
1295 files
[numfiles
++] = basename(psymtab
->filename
);
1298 ALL_SYMTABS (objfile
, symtab
)
1302 if (symtab
->filename
)
1303 files
[numfiles
++] = basename(symtab
->filename
);
1305 else if (!strcmp(symtab
->filename
,basename(symtab
->filename
))
1306 || !strncmp(pathname
,symtab
->filename
,len
))
1307 if (symtab
->filename
)
1308 files
[numfiles
++] = basename(symtab
->filename
);
1311 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1314 for (i
= 0; i
< numfiles
; i
++)
1316 if (strcmp(files
[i
],lastfile
))
1317 Tcl_ListObjAppendElement (interp
, mylist
, Tcl_NewStringObj(files
[i
], -1));
1318 lastfile
= files
[i
];
1320 Tcl_SetObjResult (interp
, mylist
);
1325 gdb_listfuncs (clientData
, interp
, argc
, argv
)
1326 ClientData clientData
;
1331 struct symtab
*symtab
;
1332 struct blockvector
*bv
;
1339 error ("wrong # args");
1341 symtab
= full_lookup_symtab (argv
[1]);
1343 error ("No such file");
1345 bv
= BLOCKVECTOR (symtab
);
1346 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1348 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1349 /* Skip the sort if this block is always sorted. */
1350 if (!BLOCK_SHOULD_SORT (b
))
1351 sort_block_syms (b
);
1352 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1354 sym
= BLOCK_SYM (b
, j
);
1355 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1358 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1361 sprintf (buf
,"{%s} 1", name
);
1364 sprintf (buf
,"{%s} 0", SYMBOL_NAME(sym
));
1365 Tcl_DStringAppendElement (result_ptr
, buf
);
1373 gdb_stop (clientData
, interp
, argc
, argv
)
1374 ClientData clientData
;
1382 quit_flag
= 1; /* hope something sees this */
1387 /* Prepare to accept a new executable file. This is called when we
1388 want to clear away everything we know about the old file, without
1389 asking the user. The Tcl code will have already asked the user if
1390 necessary. After this is called, we should be able to run the
1391 `file' command without getting any questions. */
1394 gdb_clear_file (clientData
, interp
, argc
, argv
)
1395 ClientData clientData
;
1400 if (inferior_pid
!= 0 && target_has_execution
)
1403 target_detach (NULL
, 0);
1408 if (target_has_execution
)
1411 symbol_file_command (NULL
, 0);
1413 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
1414 clear it here. FIXME: This seems like an abstraction violation
1421 /* Ask the user to confirm an exit request. */
1424 gdb_confirm_quit (clientData
, interp
, argc
, argv
)
1425 ClientData clientData
;
1432 ret
= quit_confirm ();
1433 Tcl_DStringAppendElement (result_ptr
, ret
? "1" : "0");
1437 /* Quit without asking for confirmation. */
1440 gdb_force_quit (clientData
, interp
, argc
, argv
)
1441 ClientData clientData
;
1446 quit_force ((char *) NULL
, 1);
1450 /* This implements the TCL command `gdb_disassemble'. */
1453 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
1457 disassemble_info
*info
;
1459 extern struct target_ops exec_ops
;
1463 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
1474 /* We need a different sort of line table from the normal one cuz we can't
1475 depend upon implicit line-end pc's for lines. This is because of the
1476 reordering we are about to do. */
1478 struct my_line_entry
{
1485 compare_lines (mle1p
, mle2p
)
1489 struct my_line_entry
*mle1
, *mle2
;
1492 mle1
= (struct my_line_entry
*) mle1p
;
1493 mle2
= (struct my_line_entry
*) mle2p
;
1495 val
= mle1
->line
- mle2
->line
;
1500 return mle1
->start_pc
- mle2
->start_pc
;
1504 gdb_disassemble (clientData
, interp
, argc
, argv
)
1505 ClientData clientData
;
1510 CORE_ADDR pc
, low
, high
;
1511 int mixed_source_and_assembly
;
1512 static disassemble_info di
;
1513 static int di_initialized
;
1515 if (! di_initialized
)
1517 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
1518 (fprintf_ftype
) fprintf_unfiltered
);
1519 di
.flavour
= bfd_target_unknown_flavour
;
1520 di
.memory_error_func
= dis_asm_memory_error
;
1521 di
.print_address_func
= dis_asm_print_address
;
1525 di
.mach
= tm_print_insn_info
.mach
;
1526 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
1527 di
.endian
= BFD_ENDIAN_BIG
;
1529 di
.endian
= BFD_ENDIAN_LITTLE
;
1531 if (argc
!= 3 && argc
!= 4)
1532 error ("wrong # args");
1534 if (strcmp (argv
[1], "source") == 0)
1535 mixed_source_and_assembly
= 1;
1536 else if (strcmp (argv
[1], "nosource") == 0)
1537 mixed_source_and_assembly
= 0;
1539 error ("First arg must be 'source' or 'nosource'");
1541 low
= parse_and_eval_address (argv
[2]);
1545 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
1546 error ("No function contains specified address");
1549 high
= parse_and_eval_address (argv
[3]);
1551 /* If disassemble_from_exec == -1, then we use the following heuristic to
1552 determine whether or not to do disassembly from target memory or from the
1555 If we're debugging a local process, read target memory, instead of the
1556 exec file. This makes disassembly of functions in shared libs work
1559 Else, we're debugging a remote process, and should disassemble from the
1560 exec file for speed. However, this is no good if the target modifies its
1561 code (for relocation, or whatever).
1564 if (disassemble_from_exec
== -1)
1565 if (strcmp (target_shortname
, "child") == 0
1566 || strcmp (target_shortname
, "procfs") == 0
1567 || strcmp (target_shortname
, "vxprocess") == 0)
1568 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
1570 disassemble_from_exec
= 1; /* It's remote, read the exec file */
1572 if (disassemble_from_exec
)
1573 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
1575 di
.read_memory_func
= dis_asm_read_memory
;
1577 /* If just doing straight assembly, all we need to do is disassemble
1578 everything between low and high. If doing mixed source/assembly, we've
1579 got a totally different path to follow. */
1581 if (mixed_source_and_assembly
)
1582 { /* Come here for mixed source/assembly */
1583 /* The idea here is to present a source-O-centric view of a function to
1584 the user. This means that things are presented in source order, with
1585 (possibly) out of order assembly immediately following. */
1586 struct symtab
*symtab
;
1587 struct linetable_entry
*le
;
1590 struct my_line_entry
*mle
;
1591 struct symtab_and_line sal
;
1596 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
1601 /* First, convert the linetable to a bunch of my_line_entry's. */
1603 le
= symtab
->linetable
->item
;
1604 nlines
= symtab
->linetable
->nitems
;
1609 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
1613 /* Copy linetable entries for this function into our data structure, creating
1614 end_pc's and setting out_of_order as appropriate. */
1616 /* First, skip all the preceding functions. */
1618 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
1620 /* Now, copy all entries before the end of this function. */
1623 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
1625 if (le
[i
].line
== le
[i
+ 1].line
1626 && le
[i
].pc
== le
[i
+ 1].pc
)
1627 continue; /* Ignore duplicates */
1629 mle
[newlines
].line
= le
[i
].line
;
1630 if (le
[i
].line
> le
[i
+ 1].line
)
1632 mle
[newlines
].start_pc
= le
[i
].pc
;
1633 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
1637 /* If we're on the last line, and it's part of the function, then we need to
1638 get the end pc in a special way. */
1643 mle
[newlines
].line
= le
[i
].line
;
1644 mle
[newlines
].start_pc
= le
[i
].pc
;
1645 sal
= find_pc_line (le
[i
].pc
, 0);
1646 mle
[newlines
].end_pc
= sal
.end
;
1650 /* Now, sort mle by line #s (and, then by addresses within lines). */
1653 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
1655 /* Now, for each line entry, emit the specified lines (unless they have been
1656 emitted before), followed by the assembly code for that line. */
1658 next_line
= 0; /* Force out first line */
1659 for (i
= 0; i
< newlines
; i
++)
1661 /* Print out everything from next_line to the current line. */
1663 if (mle
[i
].line
>= next_line
)
1666 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
1668 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
1670 next_line
= mle
[i
].line
+ 1;
1673 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
1676 fputs_unfiltered (" ", gdb_stdout
);
1677 print_address (pc
, gdb_stdout
);
1678 fputs_unfiltered (":\t ", gdb_stdout
);
1679 pc
+= (*tm_print_insn
) (pc
, &di
);
1680 fputs_unfiltered ("\n", gdb_stdout
);
1687 for (pc
= low
; pc
< high
; )
1690 fputs_unfiltered (" ", gdb_stdout
);
1691 print_address (pc
, gdb_stdout
);
1692 fputs_unfiltered (":\t ", gdb_stdout
);
1693 pc
+= (*tm_print_insn
) (pc
, &di
);
1694 fputs_unfiltered ("\n", gdb_stdout
);
1698 gdb_flush (gdb_stdout
);
1704 tk_command (cmd
, from_tty
)
1710 struct cleanup
*old_chain
;
1712 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1714 error_no_arg ("tcl command to interpret");
1716 retval
= Tcl_Eval (interp
, cmd
);
1718 result
= strdup (interp
->result
);
1720 old_chain
= make_cleanup (free
, result
);
1722 if (retval
!= TCL_OK
)
1725 printf_unfiltered ("%s\n", result
);
1727 do_cleanups (old_chain
);
1731 cleanup_init (ignored
)
1735 Tcl_DeleteInterp (interp
);
1739 /* Come here during long calculations to check for GUI events. Usually invoked
1740 via the QUIT macro. */
1743 gdbtk_interactive ()
1745 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1748 /* Come here when there is activity on the X file descriptor. */
1754 /* Process pending events */
1755 while (Tcl_DoOneEvent (TCL_DONT_WAIT
|TCL_ALL_EVENTS
) != 0)
1759 /* If we are doing a download, see if the download should be
1760 cancelled. FIXME: We should use a better variable name. */
1761 if (load_in_progress
)
1765 val
= Tcl_GetVar (interp
, "download_cancel_ok", TCL_GLOBAL_ONLY
);
1766 if (val
!= NULL
&& atoi (val
))
1781 /* For Cygwin32, we use a timer to periodically check for Windows
1782 messages. FIXME: It would be better to not poll, but to instead
1783 rewrite the target_wait routines to serve as input sources.
1784 Unfortunately, that will be a lot of work. */
1787 gdbtk_start_timer ()
1789 sigset_t nullsigmask
;
1790 struct sigaction action
;
1791 struct itimerval it
;
1793 /*TclDebug ("Starting timer....");*/
1794 sigemptyset (&nullsigmask
);
1796 action
.sa_handler
= x_event
;
1797 action
.sa_mask
= nullsigmask
;
1798 action
.sa_flags
= 0;
1799 sigaction (SIGALRM
, &action
, NULL
);
1801 it
.it_interval
.tv_sec
= 0;
1802 /* Check for messages twice a second. */
1803 it
.it_interval
.tv_usec
= 500 * 1000;
1804 it
.it_value
.tv_sec
= 0;
1805 it
.it_value
.tv_usec
= 500 * 1000;
1807 setitimer (ITIMER_REAL
, &it
, NULL
);
1809 gdbtk_timer_going
= 1;
1815 sigset_t nullsigmask
;
1816 struct sigaction action
;
1817 struct itimerval it
;
1819 gdbtk_timer_going
= 0;
1821 /*TclDebug ("Stopping timer.");*/
1822 sigemptyset (&nullsigmask
);
1824 action
.sa_handler
= SIG_IGN
;
1825 action
.sa_mask
= nullsigmask
;
1826 action
.sa_flags
= 0;
1827 sigaction (SIGALRM
, &action
, NULL
);
1829 it
.it_interval
.tv_sec
= 0;
1830 it
.it_interval
.tv_usec
= 0;
1831 it
.it_value
.tv_sec
= 0;
1832 it
.it_value
.tv_usec
= 0;
1833 setitimer (ITIMER_REAL
, &it
, NULL
);
1838 /* This hook function is called whenever we want to wait for the
1842 gdbtk_wait (pid
, ourstatus
)
1844 struct target_waitstatus
*ourstatus
;
1847 struct sigaction action
;
1848 static sigset_t nullsigmask
= {0};
1852 /* Needed for SunOS 4.1.x */
1853 #define SA_RESTART 0
1856 action
.sa_handler
= x_event
;
1857 action
.sa_mask
= nullsigmask
;
1858 action
.sa_flags
= SA_RESTART
;
1859 sigaction(SIGIO
, &action
, NULL
);
1862 pid
= target_wait (pid
, ourstatus
);
1865 action
.sa_handler
= SIG_IGN
;
1866 sigaction(SIGIO
, &action
, NULL
);
1872 /* This is called from execute_command, and provides a wrapper around
1873 various command routines in a place where both protocol messages and
1874 user input both flow through. Mostly this is used for indicating whether
1875 the target process is running or not.
1879 gdbtk_call_command (cmdblk
, arg
, from_tty
)
1880 struct cmd_list_element
*cmdblk
;
1885 if (cmdblk
->class == class_run
|| cmdblk
->class == class_trace
)
1888 Tcl_Eval (interp
, "gdbtk_tcl_busy");
1889 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1891 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1894 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1897 /* This function is called instead of gdb's internal command loop. This is the
1898 last chance to do anything before entering the main Tk event loop. */
1903 extern GDB_FILE
*instream
;
1905 /* We no longer want to use stdin as the command input stream */
1908 if (Tcl_Eval (interp
, "gdbtk_tcl_preloop") != TCL_OK
)
1912 /* Force errorInfo to be set up propertly. */
1913 Tcl_AddErrorInfo (interp
, "");
1915 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
1917 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
1919 fputs_unfiltered (msg
, gdb_stderr
);
1930 /* gdbtk_init installs this function as a final cleanup. */
1933 gdbtk_cleanup (dummy
)
1937 struct ide_event_handle
*h
= (struct ide_event_handle
*) dummy
;
1939 ide_interface_deregister_all (h
);
1944 /* Initialize gdbtk. */
1947 gdbtk_init ( argv0
)
1950 struct cleanup
*old_chain
;
1951 char *lib
, *gdbtk_lib
, *gdbtk_lib_tmp
, *gdbtk_file
;
1954 struct sigaction action
;
1955 static sigset_t nullsigmask
= {0};
1958 /* start-sanitize-ide */
1959 struct ide_event_handle
*h
;
1962 /* end-sanitize-ide */
1965 /* If there is no DISPLAY environment variable, Tk_Init below will fail,
1966 causing gdb to abort. If instead we simply return here, gdb will
1967 gracefully degrade to using the command line interface. */
1970 if (getenv ("DISPLAY") == NULL
)
1974 old_chain
= make_cleanup (cleanup_init
, 0);
1976 /* First init tcl and tk. */
1977 Tcl_FindExecutable (argv0
);
1978 interp
= Tcl_CreateInterp ();
1981 error ("Tcl_CreateInterp failed");
1983 if (Tcl_Init(interp
) != TCL_OK
)
1984 error ("Tcl_Init failed: %s", interp
->result
);
1987 /* For the IDE we register the cleanup later, after we've
1988 initialized events. */
1989 make_final_cleanup (gdbtk_cleanup
, NULL
);
1992 /* Initialize the Paths variable. */
1993 if (ide_initialize_paths (interp
, "gdbtcl") != TCL_OK
)
1994 error ("ide_initialize_paths failed: %s", interp
->result
);
1997 /* start-sanitize-ide */
1998 /* Find the directory where we expect to find idemanager. We ignore
1999 errors since it doesn't really matter if this fails. */
2000 libexecdir
= Tcl_GetVar2 (interp
, "Paths", "libexecdir", TCL_GLOBAL_ONLY
);
2004 h
= ide_event_init_from_environment (&errmsg
, libexecdir
);
2005 make_final_cleanup (gdbtk_cleanup
, h
);
2008 Tcl_AppendResult (interp
, "can't initialize event system: ", errmsg
,
2010 fprintf(stderr
, "WARNING: ide_event_init_client failed: %s\n", interp
->result
);
2012 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
2016 if (ide_create_tclevent_command (interp
, h
) != TCL_OK
)
2017 error ("ide_create_tclevent_command failed: %s", interp
->result
);
2019 if (ide_create_edit_command (interp
, h
) != TCL_OK
)
2020 error ("ide_create_edit_command failed: %s", interp
->result
);
2022 if (ide_create_property_command (interp
, h
) != TCL_OK
)
2023 error ("ide_create_property_command failed: %s", interp
->result
);
2025 if (ide_create_build_command (interp
, h
) != TCL_OK
)
2026 error ("ide_create_build_command failed: %s", interp
->result
);
2028 if (ide_create_window_register_command (interp
, h
, "gdb-restore")
2030 error ("ide_create_window_register_command failed: %s",
2033 if (ide_create_window_command (interp
, h
) != TCL_OK
)
2034 error ("ide_create_window_command failed: %s", interp
->result
);
2036 if (ide_create_exit_command (interp
, h
) != TCL_OK
)
2037 error ("ide_create_exit_command failed: %s", interp
->result
);
2039 if (ide_create_help_command (interp
) != TCL_OK
)
2040 error ("ide_create_help_command failed: %s", interp
->result
);
2043 if (ide_initialize (interp, "gdb") != TCL_OK)
2044 error ("ide_initialize failed: %s", interp->result);
2047 Tcl_SetVar (interp
, "GDBTK_IDE", "1", 0);
2048 Tcl_SetVar (interp
, "IDE", "1", TCL_GLOBAL_ONLY
);
2050 /* end-sanitize-ide */
2052 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
2055 /* We don't want to open the X connection until we've done all the
2056 IDE initialization. Otherwise, goofy looking unfinished windows
2057 pop up when ILU drops into the TCL event loop. */
2059 if (Tk_Init(interp
) != TCL_OK
)
2060 error ("Tk_Init failed: %s", interp
->result
);
2062 if (Itcl_Init(interp
) == TCL_ERROR
)
2063 error ("Itcl_Init failed: %s", interp
->result
);
2065 if (Tix_Init(interp
) != TCL_OK
)
2066 error ("Tix_Init failed: %s", interp
->result
);
2069 if (ide_create_messagebox_command (interp
) != TCL_OK
)
2070 error ("messagebox command initialization failed");
2071 /* On Windows, create a sizebox widget command */
2072 if (ide_create_sizebox_command (interp
) != TCL_OK
)
2073 error ("sizebox creation failed");
2074 if (ide_create_winprint_command (interp
) != TCL_OK
)
2075 error ("windows print code initialization failed");
2076 /* start-sanitize-ide */
2077 /* An interface to ShellExecute. */
2078 if (ide_create_shell_execute_command (interp
) != TCL_OK
)
2079 error ("shell execute command initialization failed");
2080 /* end-sanitize-ide */
2081 if (ide_create_win_grab_command (interp
) != TCL_OK
)
2082 error ("grab support command initialization failed");
2083 /* Path conversion functions. */
2084 if (ide_create_cygwin_path_command (interp
) != TCL_OK
)
2085 error ("cygwin path command initialization failed");
2088 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
2089 Tcl_CreateCommand (interp
, "gdb_immediate", call_wrapper
,
2090 gdb_immediate_command
, NULL
);
2091 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
2092 Tcl_CreateCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
2093 Tcl_CreateObjCommand (interp
, "gdb_listfiles", gdb_listfiles
, NULL
, NULL
);
2094 Tcl_CreateCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
2096 Tcl_CreateCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
2098 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
2099 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
2100 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
2101 gdb_fetch_registers
, NULL
);
2102 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
2103 gdb_changed_register_list
, NULL
);
2104 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
2105 gdb_disassemble
, NULL
);
2106 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
2107 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
2108 gdb_get_breakpoint_list
, NULL
);
2109 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
2110 gdb_get_breakpoint_info
, NULL
);
2111 Tcl_CreateCommand (interp
, "gdb_clear_file", call_wrapper
,
2112 gdb_clear_file
, NULL
);
2113 Tcl_CreateCommand (interp
, "gdb_confirm_quit", call_wrapper
,
2114 gdb_confirm_quit
, NULL
);
2115 Tcl_CreateCommand (interp
, "gdb_force_quit", call_wrapper
,
2116 gdb_force_quit
, NULL
);
2117 Tcl_CreateCommand (interp
, "gdb_target_has_execution",
2118 gdb_target_has_execution_command
,
2120 Tcl_CreateObjCommand (interp
, "gdb_load_info", gdb_load_info
, NULL
, NULL
);
2121 Tcl_CreateObjCommand (interp
, "gdb_get_locals", gdb_get_vars_command
,
2122 (ClientData
) 0, NULL
);
2123 Tcl_CreateObjCommand (interp
, "gdb_get_args", gdb_get_vars_command
,
2124 (ClientData
) 1, NULL
);
2125 Tcl_CreateObjCommand (interp
, "gdb_get_function", gdb_get_function_command
,
2127 Tcl_CreateObjCommand (interp
, "gdb_get_line", gdb_get_line_command
,
2129 Tcl_CreateObjCommand (interp
, "gdb_get_file", gdb_get_file_command
,
2131 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
2132 gdb_tracepoint_exists_command
, NULL
, NULL
);
2133 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
2134 gdb_get_tracepoint_info
, NULL
, NULL
);
2135 Tcl_CreateObjCommand (interp
, "gdb_actions",
2136 gdb_actions_command
, NULL
, NULL
);
2137 Tcl_CreateObjCommand (interp
, "gdb_prompt",
2138 gdb_prompt_command
, NULL
, NULL
);
2139 Tcl_CreateObjCommand (interp
, "gdb_find_file",
2140 gdb_find_file_command
, NULL
, NULL
);
2141 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
2142 gdb_get_tracepoint_list
, NULL
, NULL
);
2143 Tcl_CreateCommand (interp
, "gdb_pc_reg", get_pc_register
, NULL
, NULL
);
2144 Tcl_CreateObjCommand (interp
, "gdb_loadfile", gdb_loadfile
, NULL
, NULL
);
2145 Tcl_CreateObjCommand (interp
, "gdb_set_bp", gdb_set_bp
, NULL
, NULL
);
2147 command_loop_hook
= tk_command_loop
;
2148 print_frame_info_listing_hook
= gdbtk_print_frame_info
;
2149 query_hook
= gdbtk_query
;
2150 flush_hook
= gdbtk_flush
;
2151 create_breakpoint_hook
= gdbtk_create_breakpoint
;
2152 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
2153 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
2154 interactive_hook
= gdbtk_interactive
;
2155 target_wait_hook
= gdbtk_wait
;
2156 call_command_hook
= gdbtk_call_command
;
2157 readline_begin_hook
= gdbtk_readline_begin
;
2158 readline_hook
= gdbtk_readline
;
2159 readline_end_hook
= gdbtk_readline_end
;
2160 ui_load_progress_hook
= gdbtk_load_hash
;
2161 pre_add_symbol_hook
= gdbtk_pre_add_symbol
;
2162 post_add_symbol_hook
= gdbtk_post_add_symbol
;
2163 create_tracepoint_hook
= gdbtk_create_tracepoint
;
2164 delete_tracepoint_hook
= gdbtk_delete_tracepoint
;
2165 modify_tracepoint_hook
= gdbtk_modify_tracepoint
;
2166 pc_changed_hook
= pc_changed
;
2168 annotate_starting_hook
= gdbtk_annotate_starting
;
2169 annotate_stopped_hook
= gdbtk_annotate_stopped
;
2170 annotate_signalled_hook
= gdbtk_annotate_signalled
;
2171 annotate_exited_hook
= gdbtk_annotate_exited
;
2172 ui_loop_hook
= x_event
;
2175 /* Get the file descriptor for the X server */
2177 x_fd
= ConnectionNumber (Tk_Display (Tk_MainWindow (interp
)));
2179 /* Setup for I/O interrupts */
2181 action
.sa_mask
= nullsigmask
;
2182 action
.sa_flags
= 0;
2183 action
.sa_handler
= SIG_IGN
;
2184 sigaction(SIGIO
, &action
, NULL
);
2188 if (ioctl (x_fd
, FIOASYNC
, &i
))
2189 perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
2193 if (ioctl (x_fd
, SIOCSPGRP
, &i
))
2194 perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
2199 if (fcntl (x_fd
, F_SETOWN
, i
))
2200 perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
2201 #endif /* F_SETOWN */
2202 #endif /* !SIOCSPGRP */
2205 if (ioctl (x_fd
, I_SETSIG
, S_INPUT
|S_RDNORM
) < 0)
2206 perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
2209 #endif /* ifndef FIOASYNC */
2212 add_com ("tk", class_obscure
, tk_command
,
2213 "Send a command directly into tk.");
2215 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
2218 /* find the gdb tcl library and source main.tcl */
2220 gdbtk_lib
= getenv ("GDBTK_LIBRARY");
2222 if (access ("gdbtcl/main.tcl", R_OK
) == 0)
2223 gdbtk_lib
= "gdbtcl";
2225 gdbtk_lib
= GDBTK_LIBRARY
;
2227 gdbtk_lib_tmp
= xstrdup (gdbtk_lib
);
2230 /* see if GDBTK_LIBRARY is a path list */
2231 lib
= strtok (gdbtk_lib_tmp
, GDBTK_PATH_SEP
);
2234 if (Tcl_VarEval (interp
, "lappend auto_path ", lib
, NULL
) != TCL_OK
)
2236 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2241 gdbtk_file
= concat (lib
, "/main.tcl", (char *) NULL
);
2242 if (access (gdbtk_file
, R_OK
) == 0)
2245 Tcl_SetVar (interp
, "GDBTK_LIBRARY", lib
, 0);
2249 while ((lib
= strtok (NULL
, ":")) != NULL
);
2251 free (gdbtk_lib_tmp
);
2255 /* Try finding it with the auto path. */
2257 static const char script
[] ="\
2258 proc gdbtk_find_main {} {\n\
2259 global auto_path GDBTK_LIBRARY\n\
2260 foreach dir $auto_path {\n\
2261 set f [file join $dir main.tcl]\n\
2262 if {[file exists $f]} then {\n\
2263 set GDBTK_LIBRARY $dir\n\
2271 if (Tcl_GlobalEval (interp
, (char *) script
) != TCL_OK
)
2273 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2277 if (interp
->result
[0] != '\0')
2279 gdbtk_file
= xstrdup (interp
->result
);
2286 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2287 if (getenv("GDBTK_LIBRARY"))
2289 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
2290 fprintf_unfiltered (stderr
,
2291 "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
2295 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY
);
2296 fprintf_unfiltered (stderr
, "You might want to set GDBTK_LIBRARY\n");
2301 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
2302 prior to this point go to stdout/stderr. */
2304 fputs_unfiltered_hook
= gdbtk_fputs
;
2306 if (Tcl_EvalFile (interp
, gdbtk_file
) != TCL_OK
)
2310 /* Force errorInfo to be set up propertly. */
2311 Tcl_AddErrorInfo (interp
, "");
2313 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
2315 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2318 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
2320 fputs_unfiltered (msg
, gdb_stderr
);
2327 /* start-sanitize-ide */
2328 /* Don't do this until we have initialized. Otherwise, we may get a
2329 run command before we are ready for one. */
2330 if (ide_run_server_init (interp
, h
) != TCL_OK
)
2331 error ("ide_run_server_init failed: %s", interp
->result
);
2332 /* end-sanitize-ide */
2337 discard_cleanups (old_chain
);
2341 gdb_target_has_execution_command (clientData
, interp
, argc
, argv
)
2342 ClientData clientData
;
2349 if (target_has_execution
&& inferior_pid
!= 0)
2352 Tcl_SetIntObj (Tcl_GetObjResult (interp
), result
);
2356 /* gdb_load_info - returns information about the file about to be downloaded */
2359 gdb_load_info (clientData
, interp
, objc
, objv
)
2360 ClientData clientData
;
2363 Tcl_Obj
*CONST objv
[];
2366 struct cleanup
*old_cleanups
;
2372 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
2374 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
2375 if (loadfile_bfd
== NULL
)
2377 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Open failed", -1));
2380 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
2382 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
2384 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Bad Object File", -1));
2388 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
2390 if (s
->flags
& SEC_LOAD
)
2392 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
2395 ob
[0] = Tcl_NewStringObj((char *)bfd_get_section_name(loadfile_bfd
, s
), -1);
2396 ob
[1] = Tcl_NewLongObj ((long)size
);
2397 res
[i
++] = Tcl_NewListObj (2, ob
);
2402 Tcl_SetObjResult (interp
, Tcl_NewListObj (i
, res
));
2403 do_cleanups (old_cleanups
);
2409 gdbtk_load_hash (section
, num
)
2414 sprintf (buf
, "download_hash %s %ld", section
, num
);
2415 Tcl_Eval (interp
, buf
);
2416 return atoi (interp
->result
);
2419 /* gdb_get_vars_command -
2421 * Implements the "gdb_get_locals" and "gdb_get_args" tcl commands. This
2422 * function sets the Tcl interpreter's result to a list of variable names
2423 * depending on clientData. If clientData is one, the result is a list of
2424 * arguments; zero returns a list of locals -- all relative to the block
2425 * specified as an argument to the command. Valid commands include
2426 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
2430 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
2431 ClientData clientData
;
2434 Tcl_Obj
*CONST objv
[];
2437 struct symtabs_and_lines sals
;
2439 struct block
*block
;
2440 char **canonical
, *args
;
2441 int i
, nsyms
, arguments
;
2445 Tcl_AppendResult (interp
,
2446 "wrong # of args: should be \"",
2447 Tcl_GetStringFromObj (objv
[0], NULL
),
2448 " function:line|function|line|*addr\"");
2452 arguments
= (int) clientData
;
2453 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2454 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2455 if (sals
.nelts
== 0)
2457 Tcl_AppendResult (interp
,
2458 "error decoding line", NULL
);
2462 /* Initialize a list that will hold the results */
2463 result
= Tcl_NewListObj (0, NULL
);
2465 /* Resolve all line numbers to PC's */
2466 for (i
= 0; i
< sals
.nelts
; i
++)
2467 resolve_sal_pc (&sals
.sals
[i
]);
2469 block
= block_for_pc (sals
.sals
[0].pc
);
2472 nsyms
= BLOCK_NSYMS (block
);
2473 for (i
= 0; i
< nsyms
; i
++)
2475 sym
= BLOCK_SYM (block
, i
);
2476 switch (SYMBOL_CLASS (sym
)) {
2478 case LOC_UNDEF
: /* catches errors */
2479 case LOC_CONST
: /* constant */
2480 case LOC_STATIC
: /* static */
2481 case LOC_REGISTER
: /* register */
2482 case LOC_TYPEDEF
: /* local typedef */
2483 case LOC_LABEL
: /* local label */
2484 case LOC_BLOCK
: /* local function */
2485 case LOC_CONST_BYTES
: /* loc. byte seq. */
2486 case LOC_UNRESOLVED
: /* unresolved static */
2487 case LOC_OPTIMIZED_OUT
: /* optimized out */
2489 case LOC_ARG
: /* argument */
2490 case LOC_REF_ARG
: /* reference arg */
2491 case LOC_REGPARM
: /* register arg */
2492 case LOC_REGPARM_ADDR
: /* indirect register arg */
2493 case LOC_LOCAL_ARG
: /* stack arg */
2494 case LOC_BASEREG_ARG
: /* basereg arg */
2496 Tcl_ListObjAppendElement (interp
, result
,
2497 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2499 case LOC_LOCAL
: /* stack local */
2500 case LOC_BASEREG
: /* basereg local */
2502 Tcl_ListObjAppendElement (interp
, result
,
2503 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2507 if (BLOCK_FUNCTION (block
))
2510 block
= BLOCK_SUPERBLOCK (block
);
2513 Tcl_SetObjResult (interp
, result
);
2518 gdb_get_line_command (clientData
, interp
, objc
, objv
)
2519 ClientData clientData
;
2522 Tcl_Obj
*CONST objv
[];
2525 struct symtabs_and_lines sals
;
2526 char *args
, **canonical
;
2530 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2531 Tcl_GetStringFromObj (objv
[0], NULL
),
2536 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2537 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2538 if (sals
.nelts
== 1)
2540 Tcl_SetObjResult (interp
, Tcl_NewIntObj (sals
.sals
[0].line
));
2544 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2549 gdb_get_file_command (clientData
, interp
, objc
, objv
)
2550 ClientData clientData
;
2553 Tcl_Obj
*CONST objv
[];
2556 struct symtabs_and_lines sals
;
2557 char *args
, **canonical
;
2561 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2562 Tcl_GetStringFromObj (objv
[0], NULL
),
2567 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2568 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2569 if (sals
.nelts
== 1)
2571 Tcl_SetResult (interp
, sals
.sals
[0].symtab
->filename
, TCL_VOLATILE
);
2575 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2580 gdb_get_function_command (clientData
, interp
, objc
, objv
)
2581 ClientData clientData
;
2584 Tcl_Obj
*CONST objv
[];
2588 struct symtabs_and_lines sals
;
2589 char *args
, **canonical
;
2593 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2594 Tcl_GetStringFromObj (objv
[0], NULL
),
2599 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2600 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2601 if (sals
.nelts
== 1)
2603 resolve_sal_pc (&sals
.sals
[0]);
2604 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
2605 if (function
!= NULL
)
2607 Tcl_SetResult (interp
, function
, TCL_VOLATILE
);
2612 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2617 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
2618 ClientData clientData
;
2621 Tcl_Obj
*CONST objv
[];
2623 struct symtab_and_line sal
;
2625 struct tracepoint
*tp
;
2626 struct action_line
*al
;
2627 Tcl_Obj
*list
, *action_list
;
2628 char *filename
, *funcname
;
2632 error ("wrong # args");
2634 Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
);
2636 ALL_TRACEPOINTS (tp
)
2637 if (tp
->number
== tpnum
)
2641 error ("Tracepoint #%d does not exist", tpnum
);
2643 list
= Tcl_NewListObj (0, NULL
);
2644 sal
= find_pc_line (tp
->address
, 0);
2645 filename
= symtab_to_filename (sal
.symtab
);
2646 if (filename
== NULL
)
2648 Tcl_ListObjAppendElement (interp
, list
,
2649 Tcl_NewStringObj (filename
, -1));
2650 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
2651 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (funcname
, -1));
2652 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (sal
.line
));
2653 sprintf (tmp
, "0x%08x", tp
->address
);
2654 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (tmp
, -1));
2655 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->enabled
));
2656 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->pass_count
));
2657 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->step_count
));
2658 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->thread
));
2659 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->hit_count
));
2661 /* Append a list of actions */
2662 action_list
= Tcl_NewListObj (0, NULL
);
2663 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
2665 Tcl_ListObjAppendElement (interp
, action_list
,
2666 Tcl_NewStringObj (al
->action
, -1));
2668 Tcl_ListObjAppendElement (interp
, list
, action_list
);
2670 Tcl_SetObjResult (interp
, list
);
2675 /* TclDebug (const char *fmt, ...) works just like printf() but */
2676 /* sends the output to the GDB TK debug window. */
2677 /* Not for normal use; just a convenient tool for debugging */
2679 #ifdef ANSI_PROTOTYPES
2680 TclDebug (const char *fmt
, ...)
2687 char buf
[512], *v
[2], *merge
;
2689 #ifdef ANSI_PROTOTYPES
2690 va_start (args
, fmt
);
2694 fmt
= va_arg (args
, char *);
2700 vsprintf (buf
, fmt
, args
);
2703 merge
= Tcl_Merge (2, v
);
2704 Tcl_Eval (interp
, merge
);
2709 /* Find the full pathname to a file, searching the symbol tables */
2712 gdb_find_file_command (clientData
, interp
, objc
, objv
)
2713 ClientData clientData
;
2716 Tcl_Obj
*CONST objv
[];
2718 char *filename
= NULL
;
2723 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
2727 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
2729 filename
= st
->fullname
;
2731 if (filename
== NULL
)
2732 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("", 0));
2734 Tcl_SetObjResult (interp
, Tcl_NewStringObj (filename
, -1));
2740 gdbtk_create_tracepoint (tp
)
2741 struct tracepoint
*tp
;
2743 tracepoint_notify (tp
, "create");
2747 gdbtk_delete_tracepoint (tp
)
2748 struct tracepoint
*tp
;
2750 tracepoint_notify (tp
, "delete");
2754 gdbtk_modify_tracepoint (tp
)
2755 struct tracepoint
*tp
;
2757 tracepoint_notify (tp
, "modify");
2761 tracepoint_notify(tp
, action
)
2762 struct tracepoint
*tp
;
2767 struct symtab_and_line sal
;
2770 /* We ensure that ACTION contains no special Tcl characters, so we
2772 sal
= find_pc_line (tp
->address
, 0);
2774 filename
= symtab_to_filename (sal
.symtab
);
2775 if (filename
== NULL
)
2777 sprintf (buf
, "gdbtk_tcl_tracepoint %s %d 0x%lx %d {%s}", action
, tp
->number
,
2778 (long)tp
->address
, sal
.line
, filename
);
2780 v
= Tcl_Eval (interp
, buf
);
2784 gdbtk_fputs (interp
->result
, gdb_stdout
);
2785 gdbtk_fputs ("\n", gdb_stdout
);
2789 /* returns -1 if not found, tracepoint # if found */
2791 tracepoint_exists (char * args
)
2793 struct tracepoint
*tp
;
2795 struct symtabs_and_lines sals
;
2799 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2800 if (sals
.nelts
== 1)
2802 resolve_sal_pc (&sals
.sals
[0]);
2803 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
2804 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
2807 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
2808 strcat (file
, sals
.sals
[0].symtab
->filename
);
2810 ALL_TRACEPOINTS (tp
)
2812 if (tp
->address
== sals
.sals
[0].pc
)
2813 result
= tp
->number
;
2814 else if (tp
->source_file
!= NULL
2815 && strcmp (tp
->source_file
, file
) == 0
2816 && sals
.sals
[0].line
== tp
->line_number
)
2818 result
= tp
->number
;
2828 gdb_actions_command (clientData
, interp
, objc
, objv
)
2829 ClientData clientData
;
2832 Tcl_Obj
*CONST objv
[];
2834 struct tracepoint
*tp
;
2836 int nactions
, i
, len
;
2837 char *number
, *args
, *action
;
2839 struct action_line
*next
= NULL
, *temp
;
2843 Tcl_AppendResult (interp
, "wrong # args: should be: \"",
2844 Tcl_GetStringFromObj (objv
[0], NULL
),
2845 " number actions\"");
2849 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
2850 tp
= get_tracepoint_by_number (&args
);
2853 Tcl_AppendResult (interp
, "Tracepoint \"", number
, "\" does not exist");
2857 /* Free any existing actions */
2858 if (tp
->actions
!= NULL
)
2863 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
2864 for (i
= 0; i
< nactions
; i
++)
2866 temp
= xmalloc (sizeof (struct action_line
));
2868 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
2869 temp
->action
= savestring (action
, len
);
2870 if (sscanf (temp
->action
, "while-stepping %d", &step_count
) !=0)
2871 tp
->step_count
= step_count
;
2888 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
2889 ClientData clientData
;
2892 Tcl_Obj
*CONST objv
[];
2898 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2899 Tcl_GetStringFromObj (objv
[0], NULL
),
2900 " function:line|function|line|*addr\"");
2904 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2906 Tcl_SetObjResult (interp
, Tcl_NewIntObj (tracepoint_exists (args
)));
2910 /* Return the prompt to the interpreter */
2912 gdb_prompt_command (clientData
, interp
, objc
, objv
)
2913 ClientData clientData
;
2916 Tcl_Obj
*CONST objv
[];
2918 Tcl_SetResult (interp
, get_prompt (), TCL_VOLATILE
);
2922 /* return a list of all tracepoint numbers in interpreter */
2924 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
2925 ClientData clientData
;
2928 Tcl_Obj
*CONST objv
[];
2931 struct tracepoint
*tp
;
2933 list
= Tcl_NewListObj (0, NULL
);
2935 ALL_TRACEPOINTS (tp
)
2936 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->number
));
2938 Tcl_SetObjResult (interp
, list
);
2943 /* This hook is called whenever we are ready to load a symbol file so that
2944 the UI can notify the user... */
2946 gdbtk_pre_add_symbol (name
)
2951 v
[0] = "gdbtk_tcl_pre_add_symbol";
2953 merge
= Tcl_Merge (2, v
);
2954 Tcl_Eval (interp
, merge
);
2958 /* This hook is called whenever we finish loading a symbol file. */
2960 gdbtk_post_add_symbol ()
2962 Tcl_Eval (interp
, "gdbtk_tcl_post_add_symbol");
2968 gdbtk_print_frame_info (s
, line
, stopline
, noerror
)
2974 current_source_symtab
= s
;
2975 current_source_line
= line
;
2979 /* The lookup_symtab() in symtab.c doesn't work correctly */
2980 /* It will not work will full pathnames and if multiple */
2981 /* source files have the same basename, it will return */
2982 /* the first one instead of the correct one. This version */
2983 /* also always makes sure symtab->fullname is set. */
2985 static struct symtab
*
2986 full_lookup_symtab(file
)
2990 struct objfile
*objfile
;
2991 char *bfile
, *fullname
;
2992 struct partial_symtab
*pt
;
2997 /* first try a direct lookup */
2998 st
= lookup_symtab (file
);
3002 symtab_to_filename(st
);
3006 /* if the direct approach failed, try */
3007 /* looking up the basename and checking */
3008 /* all matches with the fullname */
3009 bfile
= basename (file
);
3010 ALL_SYMTABS (objfile
, st
)
3012 if (!strcmp (bfile
, basename(st
->filename
)))
3015 fullname
= symtab_to_filename (st
);
3017 fullname
= st
->fullname
;
3019 if (!strcmp (file
, fullname
))
3024 /* still no luck? look at psymtabs */
3025 ALL_PSYMTABS (objfile
, pt
)
3027 if (!strcmp (bfile
, basename(pt
->filename
)))
3029 st
= PSYMTAB_TO_SYMTAB (pt
);
3032 fullname
= symtab_to_filename (st
);
3033 if (!strcmp (file
, fullname
))
3042 /* gdb_loadfile loads a c source file into a text widget. */
3044 /* LTABLE_SIZE is the number of bytes to allocate for the */
3045 /* line table. Its size limits the maximum number of lines */
3046 /* in a file to 8 * LTABLE_SIZE. This memory is freed after */
3047 /* the file is loaded, so it is OK to make this very large. */
3048 /* Additional memory will be allocated if needed. */
3049 #define LTABLE_SIZE 20000
3052 gdb_loadfile (clientData
, interp
, objc
, objv
)
3053 ClientData clientData
;
3056 Tcl_Obj
*CONST objv
[];
3058 char *file
, *widget
, *line
, *buf
, msg
[128];
3059 int linenumbers
, ln
, anum
, lnum
, ltable_size
;
3060 Tcl_Obj
*a
[2], *b
[2], *cmd
;
3063 struct symtab
*symtab
;
3064 struct linetable_entry
*le
;
3068 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
3072 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
3073 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
3074 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
3076 if ((fp
= fopen ( file
, "r" )) == NULL
)
3079 symtab
= full_lookup_symtab (file
);
3086 /* Source linenumbers don't appear to be in order, and a sort is */
3087 /* too slow so the fastest solution is just to allocate a huge */
3088 /* array and set the array entry for each linenumber */
3090 ltable_size
= LTABLE_SIZE
;
3091 ltable
= (char *)malloc (LTABLE_SIZE
);
3094 sprintf(msg
, "Out of memory.");
3095 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3100 memset (ltable
, 0, LTABLE_SIZE
);
3102 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
3104 le
= symtab
->linetable
->item
;
3105 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
3107 lnum
= le
->line
>> 3;
3108 if (lnum
>= ltable_size
)
3111 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
3112 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
3114 if (new_ltable
== NULL
)
3116 sprintf(msg
, "Out of memory.");
3117 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3122 ltable
= new_ltable
;
3124 ltable
[lnum
] |= 1 << (le
->line
% 8);
3128 /* create an object with enough space, then grab its */
3129 /* buffer and sprintf directly into it. */
3130 a
[0] = Tcl_NewStringObj (ltable
, 1024);
3131 a
[1] = Tcl_NewListObj(0,NULL
);
3133 b
[0] = Tcl_NewStringObj (ltable
,1024);
3134 b
[1] = Tcl_NewStringObj ("source_tag", -1);
3135 Tcl_IncrRefCount (b
[0]);
3136 Tcl_IncrRefCount (b
[1]);
3137 line
= b
[0]->bytes
+ 1;
3138 strcpy(b
[0]->bytes
,"\t");
3141 while (fgets (line
, 980, fp
))
3145 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3146 a
[0]->length
= sprintf (buf
,"%s insert end {-\t%d} break_tag", widget
, ln
);
3148 a
[0]->length
= sprintf (buf
,"%s insert end {\t%d} \"\"", widget
, ln
);
3152 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3153 a
[0]->length
= sprintf (buf
,"%s insert end {-\t} break_tag", widget
);
3155 a
[0]->length
= sprintf (buf
,"%s insert end {\t} \"\"", widget
);
3157 b
[0]->length
= strlen(b
[0]->bytes
);
3158 Tcl_SetListObj(a
[1],2,b
);
3159 cmd
= Tcl_ConcatObj(2,a
);
3160 Tcl_EvalObj (interp
, cmd
);
3161 Tcl_DecrRefCount (cmd
);
3164 Tcl_DecrRefCount (b
[0]);
3165 Tcl_DecrRefCount (b
[0]);
3166 Tcl_DecrRefCount (b
[1]);
3167 Tcl_DecrRefCount (b
[1]);
3173 /* at some point make these static in breakpoint.c and move GUI code there */
3174 extern struct breakpoint
*set_raw_breakpoint (struct symtab_and_line sal
);
3175 extern void set_breakpoint_count (int);
3176 extern int breakpoint_count
;
3178 /* set a breakpoint by source file and line number */
3179 /* flags are as follows: */
3180 /* least significant 2 bits are disposition, rest is */
3181 /* type (normally 0).
3184 bp_breakpoint, Normal breakpoint
3185 bp_hardware_breakpoint, Hardware assisted breakpoint
3188 Disposition of breakpoint. Ie: what to do after hitting it.
3191 del_at_next_stop, Delete at next stop, whether hit or not
3193 donttouch Leave it alone
3198 gdb_set_bp (clientData
, interp
, objc
, objv
)
3199 ClientData clientData
;
3202 Tcl_Obj
*CONST objv
[];
3205 struct symtab_and_line sal
;
3206 int line
, flags
, ret
;
3207 struct breakpoint
*b
;
3209 Tcl_Obj
*a
[5], *cmd
;
3213 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
3217 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
3218 if (sal
.symtab
== NULL
)
3221 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
3224 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
3228 sal
.pc
= find_line_pc (sal
.symtab
, sal
.line
);
3232 sal
.section
= find_pc_overlay (sal
.pc
);
3233 b
= set_raw_breakpoint (sal
);
3234 set_breakpoint_count (breakpoint_count
+ 1);
3235 b
->number
= breakpoint_count
;
3236 b
->type
= flags
>> 2;
3237 b
->disposition
= flags
& 3;
3239 /* FIXME: this won't work for duplicate basenames! */
3240 sprintf (buf
, "%s:%d", basename(Tcl_GetStringFromObj( objv
[1], NULL
)), line
);
3241 b
->addr_string
= strsave (buf
);
3243 /* now send notification command back to GUI */
3244 sprintf (buf
, "0x%x", sal
.pc
);
3245 a
[0] = Tcl_NewStringObj ("gdbtk_tcl_breakpoint create", -1);
3246 a
[1] = Tcl_NewIntObj (b
->number
);
3247 a
[2] = Tcl_NewStringObj (buf
, -1);
3249 a
[4] = Tcl_NewListObj (1,&objv
[1]);
3250 cmd
= Tcl_ConcatObj(5,a
);
3251 ret
= Tcl_EvalObj (interp
, cmd
);
3252 Tcl_DecrRefCount (cmd
);
3257 /* The whole timer idea is an easy one, but POSIX does not appear to have
3258 some sort of interval timer requirement. Consequently, we cannot rely
3259 on cygwin32 to always deliver the timer's signal. This is especially
3260 painful given that all serial I/O will block the timer right now. */
3262 gdbtk_annotate_starting ()
3264 /* TclDebug ("### STARTING ###"); */
3265 gdbtk_start_timer ();
3269 gdbtk_annotate_stopped ()
3271 /* TclDebug ("### STOPPED ###"); */
3272 gdbtk_stop_timer ();
3276 gdbtk_annotate_exited ()
3278 /* TclDebug ("### EXITED ###"); */
3279 gdbtk_stop_timer ();
3283 gdbtk_annotate_signalled ()
3285 /* TclDebug ("### SIGNALLED ###"); */
3286 gdbtk_stop_timer ();
3290 /* Come here during initialize_all_files () */
3293 _initialize_gdbtk ()
3297 /* Tell the rest of the world that Gdbtk is now set up. */
3299 init_ui_hook
= gdbtk_init
;