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 'size' elements to return */
746 /* acshar: an optional ascii character to use in ASCII dump */
747 /* returns a list of 'num' elements followed by an optional */
750 gdb_get_mem (clientData
, interp
, argc
, argv
)
751 ClientData clientData
;
756 int size
, asize
, num
, i
, j
;
757 CORE_ADDR addr
, saved_addr
, ptr
;
759 struct type
*val_type
;
761 char c
, buff
[128], aschar
;
764 error ("wrong # args");
766 addr
= (CORE_ADDR
)strtoul(argv
[1],(char **)NULL
,0);
769 size
= (int)strtoul(argv
[3],(char **)NULL
,0);
770 num
= (int)strtoul(argv
[4],(char **)NULL
,0);
775 val_type
= builtin_type_char
;
779 val_type
= builtin_type_short
;
783 val_type
= builtin_type_int
;
787 val_type
= builtin_type_long_long
;
791 val_type
= builtin_type_char
;
795 for (i
=0; i
< num
; i
++)
797 vptr
= value_at (val_type
, addr
, (asection
*)NULL
);
798 print_scalar_formatted (VALUE_CONTENTS(vptr
), val_type
, format
, asize
, gdb_stdout
);
799 fputs_unfiltered (" ", gdb_stdout
);
805 val_type
= builtin_type_char
;
809 for (j
=0; j
< num
*size
; j
++)
811 c
= *(char *)VALUE_CONTENTS(value_at (val_type
, ptr
, (asection
*)NULL
));
812 if (c
< 32 || c
> 126)
821 fputs_unfiltered (buff
, gdb_stdout
);
829 map_arg_registers (argc
, argv
, func
, argp
)
832 void (*func
) PARAMS ((int regnum
, void *argp
));
837 /* Note that the test for a valid register must include checking the
838 reg_names array because NUM_REGS may be allocated for the union of the
839 register sets within a family of related processors. In this case, the
840 trailing entries of reg_names will change depending upon the particular
841 processor being debugged. */
843 if (argc
== 0) /* No args, just do all the regs */
847 && reg_names
[regnum
] != NULL
848 && *reg_names
[regnum
] != '\000';
855 /* Else, list of register #s, just do listed regs */
856 for (; argc
> 0; argc
--, argv
++)
858 regnum
= atoi (*argv
);
862 && reg_names
[regnum
] != NULL
863 && *reg_names
[regnum
] != '\000')
866 error ("bad register number");
873 get_register_name (regnum
, argp
)
875 void *argp
; /* Ignored */
877 Tcl_DStringAppendElement (result_ptr
, reg_names
[regnum
]);
880 /* This implements the TCL command `gdb_regnames', which returns a list of
881 all of the register names. */
884 gdb_regnames (clientData
, interp
, argc
, argv
)
885 ClientData clientData
;
893 return map_arg_registers (argc
, argv
, get_register_name
, NULL
);
896 #ifndef REGISTER_CONVERTIBLE
897 #define REGISTER_CONVERTIBLE(x) (0 != 0)
900 #ifndef REGISTER_CONVERT_TO_VIRTUAL
901 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
904 #ifndef INVALID_FLOAT
905 #define INVALID_FLOAT(x, y) (0 != 0)
909 get_register (regnum
, fp
)
913 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
914 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
915 int format
= (int)fp
;
920 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
922 Tcl_DStringAppendElement (result_ptr
, "Optimized out");
926 /* Convert raw data to virtual format if necessary. */
928 if (REGISTER_CONVERTIBLE (regnum
))
930 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
931 raw_buffer
, virtual_buffer
);
934 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
939 printf_filtered ("0x");
940 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
942 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
943 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
944 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
948 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
949 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
951 Tcl_DStringAppend (result_ptr
, " ", -1);
955 get_pc_register (clientData
, interp
, argc
, argv
)
956 ClientData clientData
;
961 sprintf(interp
->result
,"0x%llx",(long long)read_register(PC_REGNUM
));
966 gdb_fetch_registers (clientData
, interp
, argc
, argv
)
967 ClientData clientData
;
975 error ("wrong # args");
981 return map_arg_registers (argc
, argv
, get_register
, (void *) format
);
984 /* This contains the previous values of the registers, since the last call to
985 gdb_changed_register_list. */
987 static char old_regs
[REGISTER_BYTES
];
990 register_changed_p (regnum
, argp
)
992 void *argp
; /* Ignored */
994 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
996 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
999 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1000 REGISTER_RAW_SIZE (regnum
)) == 0)
1003 /* Found a changed register. Save new value and return its number. */
1005 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1006 REGISTER_RAW_SIZE (regnum
));
1008 dsprintf_append_element (result_ptr
, "%d", regnum
);
1012 gdb_changed_register_list (clientData
, interp
, argc
, argv
)
1013 ClientData clientData
;
1021 return map_arg_registers (argc
, argv
, register_changed_p
, NULL
);
1024 /* This implements the tcl command "gdb_immediate", which does exactly
1025 the same thing as gdb_cmd, except NONE of its outut is buffered. */
1027 gdb_immediate_command (clientData
, interp
, argc
, argv
)
1028 ClientData clientData
;
1033 Tcl_DString
*save_ptr
= NULL
;
1036 error ("wrong # args");
1041 Tcl_DStringAppend (result_ptr
, "", -1);
1042 save_ptr
= result_ptr
;
1045 execute_command (argv
[1], 1);
1047 bpstat_do_actions (&stop_bpstat
);
1049 result_ptr
= save_ptr
;
1054 /* This implements the TCL command `gdb_cmd', which sends its argument into
1055 the GDB command scanner. */
1058 gdb_cmd (clientData
, interp
, argc
, argv
)
1059 ClientData clientData
;
1064 Tcl_DString
*save_ptr
= NULL
;
1067 error ("wrong # args");
1072 /* for the load instruction (and possibly others later) we
1073 set result_ptr to NULL so gdbtk_fputs() will not buffer
1074 all the data until the command is finished. */
1076 if (strncmp ("load ", argv
[1], 5) == 0
1077 || strncmp ("while ", argv
[1], 6) == 0)
1079 Tcl_DStringAppend (result_ptr
, "", -1);
1080 save_ptr
= result_ptr
;
1082 load_in_progress
= 1;
1084 /* On Windows, use timer interrupts so that the user can cancel
1085 the download. FIXME: We may have to do something on other
1088 gdbtk_start_timer ();
1092 execute_command (argv
[1], 1);
1095 if (load_in_progress
)
1096 gdbtk_stop_timer ();
1099 load_in_progress
= 0;
1100 bpstat_do_actions (&stop_bpstat
);
1103 result_ptr
= save_ptr
;
1108 /* Client of call_wrapper - this routine performs the actual call to
1109 the client function. */
1111 struct wrapped_call_args
1122 struct wrapped_call_args
*args
;
1124 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->argc
, args
->argv
);
1128 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
1129 handles cleanups, and calls to return_to_top_level (usually via error).
1130 This is necessary in order to prevent a longjmp out of the bowels of Tk,
1131 possibly leaving things in a bad state. Since this routine can be called
1132 recursively, it needs to save and restore the contents of the jmp_buf as
1136 call_wrapper (clientData
, interp
, argc
, argv
)
1137 ClientData clientData
;
1142 struct wrapped_call_args wrapped_args
;
1143 Tcl_DString result
, *old_result_ptr
;
1144 Tcl_DString error_string
, *old_error_string_ptr
;
1146 Tcl_DStringInit (&result
);
1147 old_result_ptr
= result_ptr
;
1148 result_ptr
= &result
;
1150 Tcl_DStringInit (&error_string
);
1151 old_error_string_ptr
= error_string_ptr
;
1152 error_string_ptr
= &error_string
;
1154 wrapped_args
.func
= (Tcl_CmdProc
*)clientData
;
1155 wrapped_args
.interp
= interp
;
1156 wrapped_args
.argc
= argc
;
1157 wrapped_args
.argv
= argv
;
1158 wrapped_args
.val
= 0;
1160 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
1162 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
1165 /* Make sure the timer interrupts are turned off. */
1166 if (gdbtk_timer_going
)
1167 gdbtk_stop_timer ();
1170 gdb_flush (gdb_stderr
); /* Flush error output */
1171 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
1173 /* In case of an error, we may need to force the GUI into idle
1174 mode because gdbtk_call_command may have bombed out while in
1175 the command routine. */
1178 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1181 /* do not suppress any errors -- a remote target could have errored */
1182 load_in_progress
= 0;
1184 if (Tcl_DStringLength (&error_string
) == 0)
1186 Tcl_DStringResult (interp
, &result
);
1187 Tcl_DStringFree (&error_string
);
1189 else if (Tcl_DStringLength (&result
) == 0)
1191 Tcl_DStringResult (interp
, &error_string
);
1192 Tcl_DStringFree (&result
);
1193 Tcl_DStringFree (&error_string
);
1197 Tcl_ResetResult (interp
);
1198 Tcl_AppendResult (interp
, Tcl_DStringValue (&result
),
1199 Tcl_DStringValue (&error_string
), (char *) NULL
);
1200 Tcl_DStringFree (&result
);
1201 Tcl_DStringFree (&error_string
);
1204 result_ptr
= old_result_ptr
;
1205 error_string_ptr
= old_error_string_ptr
;
1211 return wrapped_args
.val
;
1215 comp_files (file1
, file2
)
1216 const char *file1
[], *file2
[];
1218 return strcmp(*file1
,*file2
);
1222 gdb_listfiles (clientData
, interp
, objc
, objv
)
1223 ClientData clientData
;
1226 Tcl_Obj
*CONST objv
[];
1228 struct objfile
*objfile
;
1229 struct partial_symtab
*psymtab
;
1230 struct symtab
*symtab
;
1231 char *lastfile
, *pathname
, *files
[1000];
1232 int i
, numfiles
= 0, len
= 0;
1237 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1241 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1243 mylist
= Tcl_NewListObj (0, NULL
);
1245 ALL_PSYMTABS (objfile
, psymtab
)
1249 if (psymtab
->filename
)
1250 files
[numfiles
++] = basename(psymtab
->filename
);
1252 else if (!strcmp(psymtab
->filename
,basename(psymtab
->filename
))
1253 || !strncmp(pathname
,psymtab
->filename
,len
))
1254 if (psymtab
->filename
)
1255 files
[numfiles
++] = basename(psymtab
->filename
);
1258 ALL_SYMTABS (objfile
, symtab
)
1262 if (symtab
->filename
)
1263 files
[numfiles
++] = basename(symtab
->filename
);
1265 else if (!strcmp(symtab
->filename
,basename(symtab
->filename
))
1266 || !strncmp(pathname
,symtab
->filename
,len
))
1267 if (symtab
->filename
)
1268 files
[numfiles
++] = basename(symtab
->filename
);
1271 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1274 for (i
= 0; i
< numfiles
; i
++)
1276 if (strcmp(files
[i
],lastfile
))
1277 Tcl_ListObjAppendElement (interp
, mylist
, Tcl_NewStringObj(files
[i
], -1));
1278 lastfile
= files
[i
];
1280 Tcl_SetObjResult (interp
, mylist
);
1285 gdb_listfuncs (clientData
, interp
, argc
, argv
)
1286 ClientData clientData
;
1291 struct symtab
*symtab
;
1292 struct blockvector
*bv
;
1299 error ("wrong # args");
1301 symtab
= full_lookup_symtab (argv
[1]);
1303 error ("No such file");
1305 bv
= BLOCKVECTOR (symtab
);
1306 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1308 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1309 /* Skip the sort if this block is always sorted. */
1310 if (!BLOCK_SHOULD_SORT (b
))
1311 sort_block_syms (b
);
1312 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1314 sym
= BLOCK_SYM (b
, j
);
1315 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1318 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1321 sprintf (buf
,"{%s} 1", name
);
1324 sprintf (buf
,"{%s} 0", SYMBOL_NAME(sym
));
1325 Tcl_DStringAppendElement (result_ptr
, buf
);
1333 gdb_stop (clientData
, interp
, argc
, argv
)
1334 ClientData clientData
;
1342 quit_flag
= 1; /* hope something sees this */
1347 /* Prepare to accept a new executable file. This is called when we
1348 want to clear away everything we know about the old file, without
1349 asking the user. The Tcl code will have already asked the user if
1350 necessary. After this is called, we should be able to run the
1351 `file' command without getting any questions. */
1354 gdb_clear_file (clientData
, interp
, argc
, argv
)
1355 ClientData clientData
;
1360 if (inferior_pid
!= 0 && target_has_execution
)
1363 target_detach (NULL
, 0);
1368 if (target_has_execution
)
1371 symbol_file_command (NULL
, 0);
1373 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
1374 clear it here. FIXME: This seems like an abstraction violation
1381 /* Ask the user to confirm an exit request. */
1384 gdb_confirm_quit (clientData
, interp
, argc
, argv
)
1385 ClientData clientData
;
1392 ret
= quit_confirm ();
1393 Tcl_DStringAppendElement (result_ptr
, ret
? "1" : "0");
1397 /* Quit without asking for confirmation. */
1400 gdb_force_quit (clientData
, interp
, argc
, argv
)
1401 ClientData clientData
;
1406 quit_force ((char *) NULL
, 1);
1410 /* This implements the TCL command `gdb_disassemble'. */
1413 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
1417 disassemble_info
*info
;
1419 extern struct target_ops exec_ops
;
1423 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
1434 /* We need a different sort of line table from the normal one cuz we can't
1435 depend upon implicit line-end pc's for lines. This is because of the
1436 reordering we are about to do. */
1438 struct my_line_entry
{
1445 compare_lines (mle1p
, mle2p
)
1449 struct my_line_entry
*mle1
, *mle2
;
1452 mle1
= (struct my_line_entry
*) mle1p
;
1453 mle2
= (struct my_line_entry
*) mle2p
;
1455 val
= mle1
->line
- mle2
->line
;
1460 return mle1
->start_pc
- mle2
->start_pc
;
1464 gdb_disassemble (clientData
, interp
, argc
, argv
)
1465 ClientData clientData
;
1470 CORE_ADDR pc
, low
, high
;
1471 int mixed_source_and_assembly
;
1472 static disassemble_info di
;
1473 static int di_initialized
;
1475 if (! di_initialized
)
1477 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
1478 (fprintf_ftype
) fprintf_unfiltered
);
1479 di
.flavour
= bfd_target_unknown_flavour
;
1480 di
.memory_error_func
= dis_asm_memory_error
;
1481 di
.print_address_func
= dis_asm_print_address
;
1485 di
.mach
= tm_print_insn_info
.mach
;
1486 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
1487 di
.endian
= BFD_ENDIAN_BIG
;
1489 di
.endian
= BFD_ENDIAN_LITTLE
;
1491 if (argc
!= 3 && argc
!= 4)
1492 error ("wrong # args");
1494 if (strcmp (argv
[1], "source") == 0)
1495 mixed_source_and_assembly
= 1;
1496 else if (strcmp (argv
[1], "nosource") == 0)
1497 mixed_source_and_assembly
= 0;
1499 error ("First arg must be 'source' or 'nosource'");
1501 low
= parse_and_eval_address (argv
[2]);
1505 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
1506 error ("No function contains specified address");
1509 high
= parse_and_eval_address (argv
[3]);
1511 /* If disassemble_from_exec == -1, then we use the following heuristic to
1512 determine whether or not to do disassembly from target memory or from the
1515 If we're debugging a local process, read target memory, instead of the
1516 exec file. This makes disassembly of functions in shared libs work
1519 Else, we're debugging a remote process, and should disassemble from the
1520 exec file for speed. However, this is no good if the target modifies its
1521 code (for relocation, or whatever).
1524 if (disassemble_from_exec
== -1)
1525 if (strcmp (target_shortname
, "child") == 0
1526 || strcmp (target_shortname
, "procfs") == 0
1527 || strcmp (target_shortname
, "vxprocess") == 0)
1528 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
1530 disassemble_from_exec
= 1; /* It's remote, read the exec file */
1532 if (disassemble_from_exec
)
1533 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
1535 di
.read_memory_func
= dis_asm_read_memory
;
1537 /* If just doing straight assembly, all we need to do is disassemble
1538 everything between low and high. If doing mixed source/assembly, we've
1539 got a totally different path to follow. */
1541 if (mixed_source_and_assembly
)
1542 { /* Come here for mixed source/assembly */
1543 /* The idea here is to present a source-O-centric view of a function to
1544 the user. This means that things are presented in source order, with
1545 (possibly) out of order assembly immediately following. */
1546 struct symtab
*symtab
;
1547 struct linetable_entry
*le
;
1550 struct my_line_entry
*mle
;
1551 struct symtab_and_line sal
;
1556 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
1561 /* First, convert the linetable to a bunch of my_line_entry's. */
1563 le
= symtab
->linetable
->item
;
1564 nlines
= symtab
->linetable
->nitems
;
1569 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
1573 /* Copy linetable entries for this function into our data structure, creating
1574 end_pc's and setting out_of_order as appropriate. */
1576 /* First, skip all the preceding functions. */
1578 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
1580 /* Now, copy all entries before the end of this function. */
1583 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
1585 if (le
[i
].line
== le
[i
+ 1].line
1586 && le
[i
].pc
== le
[i
+ 1].pc
)
1587 continue; /* Ignore duplicates */
1589 mle
[newlines
].line
= le
[i
].line
;
1590 if (le
[i
].line
> le
[i
+ 1].line
)
1592 mle
[newlines
].start_pc
= le
[i
].pc
;
1593 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
1597 /* If we're on the last line, and it's part of the function, then we need to
1598 get the end pc in a special way. */
1603 mle
[newlines
].line
= le
[i
].line
;
1604 mle
[newlines
].start_pc
= le
[i
].pc
;
1605 sal
= find_pc_line (le
[i
].pc
, 0);
1606 mle
[newlines
].end_pc
= sal
.end
;
1610 /* Now, sort mle by line #s (and, then by addresses within lines). */
1613 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
1615 /* Now, for each line entry, emit the specified lines (unless they have been
1616 emitted before), followed by the assembly code for that line. */
1618 next_line
= 0; /* Force out first line */
1619 for (i
= 0; i
< newlines
; i
++)
1621 /* Print out everything from next_line to the current line. */
1623 if (mle
[i
].line
>= next_line
)
1626 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
1628 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
1630 next_line
= mle
[i
].line
+ 1;
1633 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
1636 fputs_unfiltered (" ", gdb_stdout
);
1637 print_address (pc
, gdb_stdout
);
1638 fputs_unfiltered (":\t ", gdb_stdout
);
1639 pc
+= (*tm_print_insn
) (pc
, &di
);
1640 fputs_unfiltered ("\n", gdb_stdout
);
1647 for (pc
= low
; pc
< high
; )
1650 fputs_unfiltered (" ", gdb_stdout
);
1651 print_address (pc
, gdb_stdout
);
1652 fputs_unfiltered (":\t ", gdb_stdout
);
1653 pc
+= (*tm_print_insn
) (pc
, &di
);
1654 fputs_unfiltered ("\n", gdb_stdout
);
1658 gdb_flush (gdb_stdout
);
1664 tk_command (cmd
, from_tty
)
1670 struct cleanup
*old_chain
;
1672 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1674 error_no_arg ("tcl command to interpret");
1676 retval
= Tcl_Eval (interp
, cmd
);
1678 result
= strdup (interp
->result
);
1680 old_chain
= make_cleanup (free
, result
);
1682 if (retval
!= TCL_OK
)
1685 printf_unfiltered ("%s\n", result
);
1687 do_cleanups (old_chain
);
1691 cleanup_init (ignored
)
1695 Tcl_DeleteInterp (interp
);
1699 /* Come here during long calculations to check for GUI events. Usually invoked
1700 via the QUIT macro. */
1703 gdbtk_interactive ()
1705 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1708 /* Come here when there is activity on the X file descriptor. */
1714 /* Process pending events */
1715 while (Tcl_DoOneEvent (TCL_DONT_WAIT
|TCL_ALL_EVENTS
) != 0)
1719 /* If we are doing a download, see if the download should be
1720 cancelled. FIXME: We should use a better variable name. */
1721 if (load_in_progress
)
1725 val
= Tcl_GetVar (interp
, "download_cancel_ok", TCL_GLOBAL_ONLY
);
1726 if (val
!= NULL
&& atoi (val
))
1741 /* For Cygwin32, we use a timer to periodically check for Windows
1742 messages. FIXME: It would be better to not poll, but to instead
1743 rewrite the target_wait routines to serve as input sources.
1744 Unfortunately, that will be a lot of work. */
1747 gdbtk_start_timer ()
1749 sigset_t nullsigmask
;
1750 struct sigaction action
;
1751 struct itimerval it
;
1753 /*TclDebug ("Starting timer....");*/
1754 sigemptyset (&nullsigmask
);
1756 action
.sa_handler
= x_event
;
1757 action
.sa_mask
= nullsigmask
;
1758 action
.sa_flags
= 0;
1759 sigaction (SIGALRM
, &action
, NULL
);
1761 it
.it_interval
.tv_sec
= 0;
1762 /* Check for messages twice a second. */
1763 it
.it_interval
.tv_usec
= 500 * 1000;
1764 it
.it_value
.tv_sec
= 0;
1765 it
.it_value
.tv_usec
= 500 * 1000;
1767 setitimer (ITIMER_REAL
, &it
, NULL
);
1769 gdbtk_timer_going
= 1;
1775 sigset_t nullsigmask
;
1776 struct sigaction action
;
1777 struct itimerval it
;
1779 gdbtk_timer_going
= 0;
1781 /*TclDebug ("Stopping timer.");*/
1782 sigemptyset (&nullsigmask
);
1784 action
.sa_handler
= SIG_IGN
;
1785 action
.sa_mask
= nullsigmask
;
1786 action
.sa_flags
= 0;
1787 sigaction (SIGALRM
, &action
, NULL
);
1789 it
.it_interval
.tv_sec
= 0;
1790 it
.it_interval
.tv_usec
= 0;
1791 it
.it_value
.tv_sec
= 0;
1792 it
.it_value
.tv_usec
= 0;
1793 setitimer (ITIMER_REAL
, &it
, NULL
);
1798 /* This hook function is called whenever we want to wait for the
1802 gdbtk_wait (pid
, ourstatus
)
1804 struct target_waitstatus
*ourstatus
;
1807 struct sigaction action
;
1808 static sigset_t nullsigmask
= {0};
1812 /* Needed for SunOS 4.1.x */
1813 #define SA_RESTART 0
1816 action
.sa_handler
= x_event
;
1817 action
.sa_mask
= nullsigmask
;
1818 action
.sa_flags
= SA_RESTART
;
1819 sigaction(SIGIO
, &action
, NULL
);
1822 pid
= target_wait (pid
, ourstatus
);
1825 action
.sa_handler
= SIG_IGN
;
1826 sigaction(SIGIO
, &action
, NULL
);
1832 /* This is called from execute_command, and provides a wrapper around
1833 various command routines in a place where both protocol messages and
1834 user input both flow through. Mostly this is used for indicating whether
1835 the target process is running or not.
1839 gdbtk_call_command (cmdblk
, arg
, from_tty
)
1840 struct cmd_list_element
*cmdblk
;
1845 if (cmdblk
->class == class_run
|| cmdblk
->class == class_trace
)
1848 Tcl_Eval (interp
, "gdbtk_tcl_busy");
1849 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1851 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1854 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1857 /* This function is called instead of gdb's internal command loop. This is the
1858 last chance to do anything before entering the main Tk event loop. */
1863 extern GDB_FILE
*instream
;
1865 /* We no longer want to use stdin as the command input stream */
1868 if (Tcl_Eval (interp
, "gdbtk_tcl_preloop") != TCL_OK
)
1872 /* Force errorInfo to be set up propertly. */
1873 Tcl_AddErrorInfo (interp
, "");
1875 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
1877 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
1879 fputs_unfiltered (msg
, gdb_stderr
);
1890 /* gdbtk_init installs this function as a final cleanup. */
1893 gdbtk_cleanup (dummy
)
1897 struct ide_event_handle
*h
= (struct ide_event_handle
*) dummy
;
1899 ide_interface_deregister_all (h
);
1904 /* Initialize gdbtk. */
1907 gdbtk_init ( argv0
)
1910 struct cleanup
*old_chain
;
1911 char *lib
, *gdbtk_lib
, *gdbtk_lib_tmp
, *gdbtk_file
;
1914 struct sigaction action
;
1915 static sigset_t nullsigmask
= {0};
1918 /* start-sanitize-ide */
1919 struct ide_event_handle
*h
;
1922 /* end-sanitize-ide */
1925 /* If there is no DISPLAY environment variable, Tk_Init below will fail,
1926 causing gdb to abort. If instead we simply return here, gdb will
1927 gracefully degrade to using the command line interface. */
1930 if (getenv ("DISPLAY") == NULL
)
1934 old_chain
= make_cleanup (cleanup_init
, 0);
1936 /* First init tcl and tk. */
1937 Tcl_FindExecutable (argv0
);
1938 interp
= Tcl_CreateInterp ();
1941 error ("Tcl_CreateInterp failed");
1943 if (Tcl_Init(interp
) != TCL_OK
)
1944 error ("Tcl_Init failed: %s", interp
->result
);
1947 /* For the IDE we register the cleanup later, after we've
1948 initialized events. */
1949 make_final_cleanup (gdbtk_cleanup
, NULL
);
1952 /* Initialize the Paths variable. */
1953 if (ide_initialize_paths (interp
, "gdbtcl") != TCL_OK
)
1954 error ("ide_initialize_paths failed: %s", interp
->result
);
1957 /* start-sanitize-ide */
1958 /* Find the directory where we expect to find idemanager. We ignore
1959 errors since it doesn't really matter if this fails. */
1960 libexecdir
= Tcl_GetVar2 (interp
, "Paths", "libexecdir", TCL_GLOBAL_ONLY
);
1964 h
= ide_event_init_from_environment (&errmsg
, libexecdir
);
1965 make_final_cleanup (gdbtk_cleanup
, h
);
1968 Tcl_AppendResult (interp
, "can't initialize event system: ", errmsg
,
1970 fprintf(stderr
, "WARNING: ide_event_init_client failed: %s\n", interp
->result
);
1972 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
1976 if (ide_create_tclevent_command (interp
, h
) != TCL_OK
)
1977 error ("ide_create_tclevent_command failed: %s", interp
->result
);
1979 if (ide_create_edit_command (interp
, h
) != TCL_OK
)
1980 error ("ide_create_edit_command failed: %s", interp
->result
);
1982 if (ide_create_property_command (interp
, h
) != TCL_OK
)
1983 error ("ide_create_property_command failed: %s", interp
->result
);
1985 if (ide_create_build_command (interp
, h
) != TCL_OK
)
1986 error ("ide_create_build_command failed: %s", interp
->result
);
1988 if (ide_create_window_register_command (interp
, h
, "gdb-restore")
1990 error ("ide_create_window_register_command failed: %s",
1993 if (ide_create_window_command (interp
, h
) != TCL_OK
)
1994 error ("ide_create_window_command failed: %s", interp
->result
);
1996 if (ide_create_exit_command (interp
, h
) != TCL_OK
)
1997 error ("ide_create_exit_command failed: %s", interp
->result
);
1999 if (ide_create_help_command (interp
) != TCL_OK
)
2000 error ("ide_create_help_command failed: %s", interp
->result
);
2003 if (ide_initialize (interp, "gdb") != TCL_OK)
2004 error ("ide_initialize failed: %s", interp->result);
2007 Tcl_SetVar (interp
, "GDBTK_IDE", "1", 0);
2008 Tcl_SetVar (interp
, "IDE", "1", TCL_GLOBAL_ONLY
);
2010 /* end-sanitize-ide */
2012 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
2015 /* We don't want to open the X connection until we've done all the
2016 IDE initialization. Otherwise, goofy looking unfinished windows
2017 pop up when ILU drops into the TCL event loop. */
2019 if (Tk_Init(interp
) != TCL_OK
)
2020 error ("Tk_Init failed: %s", interp
->result
);
2022 if (Itcl_Init(interp
) == TCL_ERROR
)
2023 error ("Itcl_Init failed: %s", interp
->result
);
2025 if (Tix_Init(interp
) != TCL_OK
)
2026 error ("Tix_Init failed: %s", interp
->result
);
2029 if (ide_create_messagebox_command (interp
) != TCL_OK
)
2030 error ("messagebox command initialization failed");
2031 /* On Windows, create a sizebox widget command */
2032 if (ide_create_sizebox_command (interp
) != TCL_OK
)
2033 error ("sizebox creation failed");
2034 if (ide_create_winprint_command (interp
) != TCL_OK
)
2035 error ("windows print code initialization failed");
2036 /* start-sanitize-ide */
2037 /* An interface to ShellExecute. */
2038 if (ide_create_shell_execute_command (interp
) != TCL_OK
)
2039 error ("shell execute command initialization failed");
2040 /* end-sanitize-ide */
2041 if (ide_create_win_grab_command (interp
) != TCL_OK
)
2042 error ("grab support command initialization failed");
2043 /* Path conversion functions. */
2044 if (ide_create_cygwin_path_command (interp
) != TCL_OK
)
2045 error ("cygwin path command initialization failed");
2048 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
2049 Tcl_CreateCommand (interp
, "gdb_immediate", call_wrapper
,
2050 gdb_immediate_command
, NULL
);
2051 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
2052 Tcl_CreateCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
2053 Tcl_CreateObjCommand (interp
, "gdb_listfiles", gdb_listfiles
, NULL
, NULL
);
2054 Tcl_CreateCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
2056 Tcl_CreateCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
2058 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
2059 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
2060 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
2061 gdb_fetch_registers
, NULL
);
2062 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
2063 gdb_changed_register_list
, NULL
);
2064 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
2065 gdb_disassemble
, NULL
);
2066 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
2067 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
2068 gdb_get_breakpoint_list
, NULL
);
2069 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
2070 gdb_get_breakpoint_info
, NULL
);
2071 Tcl_CreateCommand (interp
, "gdb_clear_file", call_wrapper
,
2072 gdb_clear_file
, NULL
);
2073 Tcl_CreateCommand (interp
, "gdb_confirm_quit", call_wrapper
,
2074 gdb_confirm_quit
, NULL
);
2075 Tcl_CreateCommand (interp
, "gdb_force_quit", call_wrapper
,
2076 gdb_force_quit
, NULL
);
2077 Tcl_CreateCommand (interp
, "gdb_target_has_execution",
2078 gdb_target_has_execution_command
,
2080 Tcl_CreateObjCommand (interp
, "gdb_load_info", gdb_load_info
, NULL
, NULL
);
2081 Tcl_CreateObjCommand (interp
, "gdb_get_locals", gdb_get_vars_command
,
2082 (ClientData
) 0, NULL
);
2083 Tcl_CreateObjCommand (interp
, "gdb_get_args", gdb_get_vars_command
,
2084 (ClientData
) 1, NULL
);
2085 Tcl_CreateObjCommand (interp
, "gdb_get_function", gdb_get_function_command
,
2087 Tcl_CreateObjCommand (interp
, "gdb_get_line", gdb_get_line_command
,
2089 Tcl_CreateObjCommand (interp
, "gdb_get_file", gdb_get_file_command
,
2091 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
2092 gdb_tracepoint_exists_command
, NULL
, NULL
);
2093 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
2094 gdb_get_tracepoint_info
, NULL
, NULL
);
2095 Tcl_CreateObjCommand (interp
, "gdb_actions",
2096 gdb_actions_command
, NULL
, NULL
);
2097 Tcl_CreateObjCommand (interp
, "gdb_prompt",
2098 gdb_prompt_command
, NULL
, NULL
);
2099 Tcl_CreateObjCommand (interp
, "gdb_find_file",
2100 gdb_find_file_command
, NULL
, NULL
);
2101 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
2102 gdb_get_tracepoint_list
, NULL
, NULL
);
2103 Tcl_CreateCommand (interp
, "gdb_pc_reg", get_pc_register
, NULL
, NULL
);
2104 Tcl_CreateObjCommand (interp
, "gdb_loadfile", gdb_loadfile
, NULL
, NULL
);
2105 Tcl_CreateObjCommand (interp
, "gdb_set_bp", gdb_set_bp
, NULL
, NULL
);
2107 command_loop_hook
= tk_command_loop
;
2108 print_frame_info_listing_hook
= gdbtk_print_frame_info
;
2109 query_hook
= gdbtk_query
;
2110 flush_hook
= gdbtk_flush
;
2111 create_breakpoint_hook
= gdbtk_create_breakpoint
;
2112 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
2113 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
2114 interactive_hook
= gdbtk_interactive
;
2115 target_wait_hook
= gdbtk_wait
;
2116 call_command_hook
= gdbtk_call_command
;
2117 readline_begin_hook
= gdbtk_readline_begin
;
2118 readline_hook
= gdbtk_readline
;
2119 readline_end_hook
= gdbtk_readline_end
;
2120 ui_load_progress_hook
= gdbtk_load_hash
;
2121 pre_add_symbol_hook
= gdbtk_pre_add_symbol
;
2122 post_add_symbol_hook
= gdbtk_post_add_symbol
;
2123 create_tracepoint_hook
= gdbtk_create_tracepoint
;
2124 delete_tracepoint_hook
= gdbtk_delete_tracepoint
;
2125 modify_tracepoint_hook
= gdbtk_modify_tracepoint
;
2126 pc_changed_hook
= pc_changed
;
2128 annotate_starting_hook
= gdbtk_annotate_starting
;
2129 annotate_stopped_hook
= gdbtk_annotate_stopped
;
2130 annotate_signalled_hook
= gdbtk_annotate_signalled
;
2131 annotate_exited_hook
= gdbtk_annotate_exited
;
2132 ui_loop_hook
= x_event
;
2135 /* Get the file descriptor for the X server */
2137 x_fd
= ConnectionNumber (Tk_Display (Tk_MainWindow (interp
)));
2139 /* Setup for I/O interrupts */
2141 action
.sa_mask
= nullsigmask
;
2142 action
.sa_flags
= 0;
2143 action
.sa_handler
= SIG_IGN
;
2144 sigaction(SIGIO
, &action
, NULL
);
2148 if (ioctl (x_fd
, FIOASYNC
, &i
))
2149 perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
2153 if (ioctl (x_fd
, SIOCSPGRP
, &i
))
2154 perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
2159 if (fcntl (x_fd
, F_SETOWN
, i
))
2160 perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
2161 #endif /* F_SETOWN */
2162 #endif /* !SIOCSPGRP */
2165 if (ioctl (x_fd
, I_SETSIG
, S_INPUT
|S_RDNORM
) < 0)
2166 perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
2169 #endif /* ifndef FIOASYNC */
2172 add_com ("tk", class_obscure
, tk_command
,
2173 "Send a command directly into tk.");
2175 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
2178 /* find the gdb tcl library and source main.tcl */
2180 gdbtk_lib
= getenv ("GDBTK_LIBRARY");
2182 if (access ("gdbtcl/main.tcl", R_OK
) == 0)
2183 gdbtk_lib
= "gdbtcl";
2185 gdbtk_lib
= GDBTK_LIBRARY
;
2187 gdbtk_lib_tmp
= xstrdup (gdbtk_lib
);
2190 /* see if GDBTK_LIBRARY is a path list */
2191 lib
= strtok (gdbtk_lib_tmp
, GDBTK_PATH_SEP
);
2194 if (Tcl_VarEval (interp
, "lappend auto_path ", lib
, NULL
) != TCL_OK
)
2196 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2201 gdbtk_file
= concat (lib
, "/main.tcl", (char *) NULL
);
2202 if (access (gdbtk_file
, R_OK
) == 0)
2205 Tcl_SetVar (interp
, "GDBTK_LIBRARY", lib
, 0);
2209 while ((lib
= strtok (NULL
, ":")) != NULL
);
2211 free (gdbtk_lib_tmp
);
2215 /* Try finding it with the auto path. */
2217 static const char script
[] ="\
2218 proc gdbtk_find_main {} {\n\
2219 global auto_path GDBTK_LIBRARY\n\
2220 foreach dir $auto_path {\n\
2221 set f [file join $dir main.tcl]\n\
2222 if {[file exists $f]} then {\n\
2223 set GDBTK_LIBRARY $dir\n\
2231 if (Tcl_GlobalEval (interp
, (char *) script
) != TCL_OK
)
2233 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2237 if (interp
->result
[0] != '\0')
2239 gdbtk_file
= xstrdup (interp
->result
);
2246 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2247 if (getenv("GDBTK_LIBRARY"))
2249 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
2250 fprintf_unfiltered (stderr
,
2251 "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
2255 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY
);
2256 fprintf_unfiltered (stderr
, "You might want to set GDBTK_LIBRARY\n");
2261 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
2262 prior to this point go to stdout/stderr. */
2264 fputs_unfiltered_hook
= gdbtk_fputs
;
2266 if (Tcl_EvalFile (interp
, gdbtk_file
) != TCL_OK
)
2270 /* Force errorInfo to be set up propertly. */
2271 Tcl_AddErrorInfo (interp
, "");
2273 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
2275 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2278 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
2280 fputs_unfiltered (msg
, gdb_stderr
);
2287 /* start-sanitize-ide */
2288 /* Don't do this until we have initialized. Otherwise, we may get a
2289 run command before we are ready for one. */
2290 if (ide_run_server_init (interp
, h
) != TCL_OK
)
2291 error ("ide_run_server_init failed: %s", interp
->result
);
2292 /* end-sanitize-ide */
2297 discard_cleanups (old_chain
);
2301 gdb_target_has_execution_command (clientData
, interp
, argc
, argv
)
2302 ClientData clientData
;
2309 if (target_has_execution
&& inferior_pid
!= 0)
2312 Tcl_SetIntObj (Tcl_GetObjResult (interp
), result
);
2316 /* gdb_load_info - returns information about the file about to be downloaded */
2319 gdb_load_info (clientData
, interp
, objc
, objv
)
2320 ClientData clientData
;
2323 Tcl_Obj
*CONST objv
[];
2326 struct cleanup
*old_cleanups
;
2332 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
2334 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
2335 if (loadfile_bfd
== NULL
)
2337 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Open failed", -1));
2340 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
2342 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
2344 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Bad Object File", -1));
2348 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
2350 if (s
->flags
& SEC_LOAD
)
2352 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
2355 ob
[0] = Tcl_NewStringObj((char *)bfd_get_section_name(loadfile_bfd
, s
), -1);
2356 ob
[1] = Tcl_NewLongObj ((long)size
);
2357 res
[i
++] = Tcl_NewListObj (2, ob
);
2362 Tcl_SetObjResult (interp
, Tcl_NewListObj (i
, res
));
2363 do_cleanups (old_cleanups
);
2369 gdbtk_load_hash (section
, num
)
2374 sprintf (buf
, "download_hash %s %ld", section
, num
);
2375 Tcl_Eval (interp
, buf
);
2376 return atoi (interp
->result
);
2379 /* gdb_get_vars_command -
2381 * Implements the "gdb_get_locals" and "gdb_get_args" tcl commands. This
2382 * function sets the Tcl interpreter's result to a list of variable names
2383 * depending on clientData. If clientData is one, the result is a list of
2384 * arguments; zero returns a list of locals -- all relative to the block
2385 * specified as an argument to the command. Valid commands include
2386 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
2390 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
2391 ClientData clientData
;
2394 Tcl_Obj
*CONST objv
[];
2397 struct symtabs_and_lines sals
;
2399 struct block
*block
;
2400 char **canonical
, *args
;
2401 int i
, nsyms
, arguments
;
2405 Tcl_AppendResult (interp
,
2406 "wrong # of args: should be \"",
2407 Tcl_GetStringFromObj (objv
[0], NULL
),
2408 " function:line|function|line|*addr\"");
2412 arguments
= (int) clientData
;
2413 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2414 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2415 if (sals
.nelts
== 0)
2417 Tcl_AppendResult (interp
,
2418 "error decoding line", NULL
);
2422 /* Initialize a list that will hold the results */
2423 result
= Tcl_NewListObj (0, NULL
);
2425 /* Resolve all line numbers to PC's */
2426 for (i
= 0; i
< sals
.nelts
; i
++)
2427 resolve_sal_pc (&sals
.sals
[i
]);
2429 block
= block_for_pc (sals
.sals
[0].pc
);
2432 nsyms
= BLOCK_NSYMS (block
);
2433 for (i
= 0; i
< nsyms
; i
++)
2435 sym
= BLOCK_SYM (block
, i
);
2436 switch (SYMBOL_CLASS (sym
)) {
2438 case LOC_UNDEF
: /* catches errors */
2439 case LOC_CONST
: /* constant */
2440 case LOC_STATIC
: /* static */
2441 case LOC_REGISTER
: /* register */
2442 case LOC_TYPEDEF
: /* local typedef */
2443 case LOC_LABEL
: /* local label */
2444 case LOC_BLOCK
: /* local function */
2445 case LOC_CONST_BYTES
: /* loc. byte seq. */
2446 case LOC_UNRESOLVED
: /* unresolved static */
2447 case LOC_OPTIMIZED_OUT
: /* optimized out */
2449 case LOC_ARG
: /* argument */
2450 case LOC_REF_ARG
: /* reference arg */
2451 case LOC_REGPARM
: /* register arg */
2452 case LOC_REGPARM_ADDR
: /* indirect register arg */
2453 case LOC_LOCAL_ARG
: /* stack arg */
2454 case LOC_BASEREG_ARG
: /* basereg arg */
2456 Tcl_ListObjAppendElement (interp
, result
,
2457 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2459 case LOC_LOCAL
: /* stack local */
2460 case LOC_BASEREG
: /* basereg local */
2462 Tcl_ListObjAppendElement (interp
, result
,
2463 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2467 if (BLOCK_FUNCTION (block
))
2470 block
= BLOCK_SUPERBLOCK (block
);
2473 Tcl_SetObjResult (interp
, result
);
2478 gdb_get_line_command (clientData
, interp
, objc
, objv
)
2479 ClientData clientData
;
2482 Tcl_Obj
*CONST objv
[];
2485 struct symtabs_and_lines sals
;
2486 char *args
, **canonical
;
2490 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2491 Tcl_GetStringFromObj (objv
[0], NULL
),
2496 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2497 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2498 if (sals
.nelts
== 1)
2500 Tcl_SetObjResult (interp
, Tcl_NewIntObj (sals
.sals
[0].line
));
2504 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2509 gdb_get_file_command (clientData
, interp
, objc
, objv
)
2510 ClientData clientData
;
2513 Tcl_Obj
*CONST objv
[];
2516 struct symtabs_and_lines sals
;
2517 char *args
, **canonical
;
2521 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2522 Tcl_GetStringFromObj (objv
[0], NULL
),
2527 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2528 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2529 if (sals
.nelts
== 1)
2531 Tcl_SetResult (interp
, sals
.sals
[0].symtab
->filename
, TCL_VOLATILE
);
2535 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2540 gdb_get_function_command (clientData
, interp
, objc
, objv
)
2541 ClientData clientData
;
2544 Tcl_Obj
*CONST objv
[];
2548 struct symtabs_and_lines sals
;
2549 char *args
, **canonical
;
2553 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2554 Tcl_GetStringFromObj (objv
[0], NULL
),
2559 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2560 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2561 if (sals
.nelts
== 1)
2563 resolve_sal_pc (&sals
.sals
[0]);
2564 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
2565 if (function
!= NULL
)
2567 Tcl_SetResult (interp
, function
, TCL_VOLATILE
);
2572 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2577 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
2578 ClientData clientData
;
2581 Tcl_Obj
*CONST objv
[];
2583 struct symtab_and_line sal
;
2585 struct tracepoint
*tp
;
2586 struct action_line
*al
;
2587 Tcl_Obj
*list
, *action_list
;
2588 char *filename
, *funcname
;
2592 error ("wrong # args");
2594 Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
);
2596 ALL_TRACEPOINTS (tp
)
2597 if (tp
->number
== tpnum
)
2601 error ("Tracepoint #%d does not exist", tpnum
);
2603 list
= Tcl_NewListObj (0, NULL
);
2604 sal
= find_pc_line (tp
->address
, 0);
2605 filename
= symtab_to_filename (sal
.symtab
);
2606 if (filename
== NULL
)
2608 Tcl_ListObjAppendElement (interp
, list
,
2609 Tcl_NewStringObj (filename
, -1));
2610 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
2611 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (funcname
, -1));
2612 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (sal
.line
));
2613 sprintf (tmp
, "0x%08x", tp
->address
);
2614 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (tmp
, -1));
2615 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->enabled
));
2616 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->pass_count
));
2617 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->step_count
));
2618 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->thread
));
2619 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->hit_count
));
2621 /* Append a list of actions */
2622 action_list
= Tcl_NewListObj (0, NULL
);
2623 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
2625 Tcl_ListObjAppendElement (interp
, action_list
,
2626 Tcl_NewStringObj (al
->action
, -1));
2628 Tcl_ListObjAppendElement (interp
, list
, action_list
);
2630 Tcl_SetObjResult (interp
, list
);
2635 /* TclDebug (const char *fmt, ...) works just like printf() but */
2636 /* sends the output to the GDB TK debug window. */
2637 /* Not for normal use; just a convenient tool for debugging */
2639 #ifdef ANSI_PROTOTYPES
2640 TclDebug (const char *fmt
, ...)
2647 char buf
[512], *v
[2], *merge
;
2649 #ifdef ANSI_PROTOTYPES
2650 va_start (args
, fmt
);
2654 fmt
= va_arg (args
, char *);
2660 vsprintf (buf
, fmt
, args
);
2663 merge
= Tcl_Merge (2, v
);
2664 Tcl_Eval (interp
, merge
);
2669 /* Find the full pathname to a file, searching the symbol tables */
2672 gdb_find_file_command (clientData
, interp
, objc
, objv
)
2673 ClientData clientData
;
2676 Tcl_Obj
*CONST objv
[];
2678 char *filename
= NULL
;
2683 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
2687 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
2689 filename
= st
->fullname
;
2691 if (filename
== NULL
)
2692 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("", 0));
2694 Tcl_SetObjResult (interp
, Tcl_NewStringObj (filename
, -1));
2700 gdbtk_create_tracepoint (tp
)
2701 struct tracepoint
*tp
;
2703 tracepoint_notify (tp
, "create");
2707 gdbtk_delete_tracepoint (tp
)
2708 struct tracepoint
*tp
;
2710 tracepoint_notify (tp
, "delete");
2714 gdbtk_modify_tracepoint (tp
)
2715 struct tracepoint
*tp
;
2717 tracepoint_notify (tp
, "modify");
2721 tracepoint_notify(tp
, action
)
2722 struct tracepoint
*tp
;
2727 struct symtab_and_line sal
;
2730 /* We ensure that ACTION contains no special Tcl characters, so we
2732 sal
= find_pc_line (tp
->address
, 0);
2734 filename
= symtab_to_filename (sal
.symtab
);
2735 if (filename
== NULL
)
2737 sprintf (buf
, "gdbtk_tcl_tracepoint %s %d 0x%lx %d {%s}", action
, tp
->number
,
2738 (long)tp
->address
, sal
.line
, filename
);
2740 v
= Tcl_Eval (interp
, buf
);
2744 gdbtk_fputs (interp
->result
, gdb_stdout
);
2745 gdbtk_fputs ("\n", gdb_stdout
);
2749 /* returns -1 if not found, tracepoint # if found */
2751 tracepoint_exists (char * args
)
2753 struct tracepoint
*tp
;
2755 struct symtabs_and_lines sals
;
2759 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2760 if (sals
.nelts
== 1)
2762 resolve_sal_pc (&sals
.sals
[0]);
2763 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
2764 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
2767 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
2768 strcat (file
, sals
.sals
[0].symtab
->filename
);
2770 ALL_TRACEPOINTS (tp
)
2772 if (tp
->address
== sals
.sals
[0].pc
)
2773 result
= tp
->number
;
2774 else if (tp
->source_file
!= NULL
2775 && strcmp (tp
->source_file
, file
) == 0
2776 && sals
.sals
[0].line
== tp
->line_number
)
2778 result
= tp
->number
;
2788 gdb_actions_command (clientData
, interp
, objc
, objv
)
2789 ClientData clientData
;
2792 Tcl_Obj
*CONST objv
[];
2794 struct tracepoint
*tp
;
2796 int nactions
, i
, len
;
2797 char *number
, *args
, *action
;
2799 struct action_line
*next
= NULL
, *temp
;
2803 Tcl_AppendResult (interp
, "wrong # args: should be: \"",
2804 Tcl_GetStringFromObj (objv
[0], NULL
),
2805 " number actions\"");
2809 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
2810 tp
= get_tracepoint_by_number (&args
);
2813 Tcl_AppendResult (interp
, "Tracepoint \"", number
, "\" does not exist");
2817 /* Free any existing actions */
2818 if (tp
->actions
!= NULL
)
2823 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
2824 for (i
= 0; i
< nactions
; i
++)
2826 temp
= xmalloc (sizeof (struct action_line
));
2828 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
2829 temp
->action
= savestring (action
, len
);
2830 if (sscanf (temp
->action
, "while-stepping %d", &step_count
) !=0)
2831 tp
->step_count
= step_count
;
2848 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
2849 ClientData clientData
;
2852 Tcl_Obj
*CONST objv
[];
2858 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2859 Tcl_GetStringFromObj (objv
[0], NULL
),
2860 " function:line|function|line|*addr\"");
2864 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2866 Tcl_SetObjResult (interp
, Tcl_NewIntObj (tracepoint_exists (args
)));
2870 /* Return the prompt to the interpreter */
2872 gdb_prompt_command (clientData
, interp
, objc
, objv
)
2873 ClientData clientData
;
2876 Tcl_Obj
*CONST objv
[];
2878 Tcl_SetResult (interp
, get_prompt (), TCL_VOLATILE
);
2882 /* return a list of all tracepoint numbers in interpreter */
2884 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
2885 ClientData clientData
;
2888 Tcl_Obj
*CONST objv
[];
2891 struct tracepoint
*tp
;
2893 list
= Tcl_NewListObj (0, NULL
);
2895 ALL_TRACEPOINTS (tp
)
2896 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->number
));
2898 Tcl_SetObjResult (interp
, list
);
2903 /* This hook is called whenever we are ready to load a symbol file so that
2904 the UI can notify the user... */
2906 gdbtk_pre_add_symbol (name
)
2911 sprintf (command
, "gdbtk_tcl_pre_add_symbol %s", name
);
2912 Tcl_Eval (interp
, command
);
2915 /* This hook is called whenever we finish loading a symbol file. */
2917 gdbtk_post_add_symbol ()
2919 Tcl_Eval (interp
, "gdbtk_tcl_post_add_symbol");
2925 gdbtk_print_frame_info (s
, line
, stopline
, noerror
)
2931 current_source_symtab
= s
;
2932 current_source_line
= line
;
2936 /* The lookup_symtab() in symtab.c doesn't work correctly */
2937 /* It will not work will full pathnames and if multiple */
2938 /* source files have the same basename, it will return */
2939 /* the first one instead of the correct one. This version */
2940 /* also always makes sure symtab->fullname is set. */
2942 static struct symtab
*
2943 full_lookup_symtab(file
)
2947 struct objfile
*objfile
;
2948 char *bfile
, *fullname
;
2949 struct partial_symtab
*pt
;
2954 /* first try a direct lookup */
2955 st
= lookup_symtab (file
);
2959 symtab_to_filename(st
);
2963 /* if the direct approach failed, try */
2964 /* looking up the basename and checking */
2965 /* all matches with the fullname */
2966 bfile
= basename (file
);
2967 ALL_SYMTABS (objfile
, st
)
2969 if (!strcmp (bfile
, basename(st
->filename
)))
2972 fullname
= symtab_to_filename (st
);
2974 fullname
= st
->fullname
;
2976 if (!strcmp (file
, fullname
))
2981 /* still no luck? look at psymtabs */
2982 ALL_PSYMTABS (objfile
, pt
)
2984 if (!strcmp (bfile
, basename(pt
->filename
)))
2986 st
= PSYMTAB_TO_SYMTAB (pt
);
2989 fullname
= symtab_to_filename (st
);
2990 if (!strcmp (file
, fullname
))
2999 /* gdb_loadfile loads a c source file into a text widget. */
3001 /* LTABLE_SIZE is the number of bytes to allocate for the */
3002 /* line table. Its size limits the maximum number of lines */
3003 /* in a file to 8 * LTABLE_SIZE. This memory is freed after */
3004 /* the file is loaded, so it is OK to make this very large. */
3005 /* Additional memory will be allocated if needed. */
3006 #define LTABLE_SIZE 20000
3009 gdb_loadfile (clientData
, interp
, objc
, objv
)
3010 ClientData clientData
;
3013 Tcl_Obj
*CONST objv
[];
3015 char *file
, *widget
, *line
, *buf
, msg
[128];
3016 int linenumbers
, ln
, anum
, lnum
, ltable_size
;
3017 Tcl_Obj
*a
[2], *b
[2], *cmd
;
3020 struct symtab
*symtab
;
3021 struct linetable_entry
*le
;
3025 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
3029 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
3030 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
3031 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
3033 if ((fp
= fopen ( file
, "r" )) == NULL
)
3036 symtab
= full_lookup_symtab (file
);
3043 /* Source linenumbers don't appear to be in order, and a sort is */
3044 /* too slow so the fastest solution is just to allocate a huge */
3045 /* array and set the array entry for each linenumber */
3047 ltable_size
= LTABLE_SIZE
;
3048 ltable
= (char *)malloc (LTABLE_SIZE
);
3051 sprintf(msg
, "Out of memory.");
3052 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3057 memset (ltable
, 0, LTABLE_SIZE
);
3059 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
3061 le
= symtab
->linetable
->item
;
3062 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
3064 lnum
= le
->line
>> 3;
3065 if (lnum
>= ltable_size
)
3068 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
3069 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
3071 if (new_ltable
== NULL
)
3073 sprintf(msg
, "Out of memory.");
3074 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3079 ltable
= new_ltable
;
3081 ltable
[lnum
] |= 1 << (le
->line
% 8);
3085 /* create an object with enough space, then grab its */
3086 /* buffer and sprintf directly into it. */
3087 a
[0] = Tcl_NewStringObj (ltable
, 1024);
3088 a
[1] = Tcl_NewListObj(0,NULL
);
3090 b
[0] = Tcl_NewStringObj (ltable
,1024);
3091 b
[1] = Tcl_NewStringObj ("source_tag", -1);
3092 Tcl_IncrRefCount (b
[0]);
3093 Tcl_IncrRefCount (b
[1]);
3094 line
= b
[0]->bytes
+ 1;
3095 strcpy(b
[0]->bytes
,"\t");
3098 while (fgets (line
, 980, fp
))
3102 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3103 a
[0]->length
= sprintf (buf
,"%s insert end {-\t%d} break_tag", widget
, ln
);
3105 a
[0]->length
= sprintf (buf
,"%s insert end {\t%d} \"\"", widget
, ln
);
3109 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3110 a
[0]->length
= sprintf (buf
,"%s insert end {-\t} break_tag", widget
);
3112 a
[0]->length
= sprintf (buf
,"%s insert end {\t} \"\"", widget
);
3114 b
[0]->length
= strlen(b
[0]->bytes
);
3115 Tcl_SetListObj(a
[1],2,b
);
3116 cmd
= Tcl_ConcatObj(2,a
);
3117 Tcl_EvalObj (interp
, cmd
);
3118 Tcl_DecrRefCount (cmd
);
3121 Tcl_DecrRefCount (b
[0]);
3122 Tcl_DecrRefCount (b
[0]);
3123 Tcl_DecrRefCount (b
[1]);
3124 Tcl_DecrRefCount (b
[1]);
3130 /* at some point make these static in breakpoint.c and move GUI code there */
3131 extern struct breakpoint
*set_raw_breakpoint (struct symtab_and_line sal
);
3132 extern void set_breakpoint_count (int);
3133 extern int breakpoint_count
;
3135 /* set a breakpoint by source file and line number */
3136 /* flags are as follows: */
3137 /* least significant 2 bits are disposition, rest is */
3138 /* type (normally 0).
3141 bp_breakpoint, Normal breakpoint
3142 bp_hardware_breakpoint, Hardware assisted breakpoint
3145 Disposition of breakpoint. Ie: what to do after hitting it.
3148 del_at_next_stop, Delete at next stop, whether hit or not
3150 donttouch Leave it alone
3155 gdb_set_bp (clientData
, interp
, objc
, objv
)
3156 ClientData clientData
;
3159 Tcl_Obj
*CONST objv
[];
3162 struct symtab_and_line sal
;
3163 int line
, flags
, ret
;
3164 struct breakpoint
*b
;
3166 Tcl_Obj
*a
[5], *cmd
;
3170 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
3174 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
3175 if (sal
.symtab
== NULL
)
3178 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
3181 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
3185 sal
.pc
= find_line_pc (sal
.symtab
, sal
.line
);
3189 sal
.section
= find_pc_overlay (sal
.pc
);
3190 b
= set_raw_breakpoint (sal
);
3191 set_breakpoint_count (breakpoint_count
+ 1);
3192 b
->number
= breakpoint_count
;
3193 b
->type
= flags
>> 2;
3194 b
->disposition
= flags
& 3;
3196 /* FIXME: this won't work for duplicate basenames! */
3197 sprintf (buf
, "%s:%d", basename(Tcl_GetStringFromObj( objv
[1], NULL
)), line
);
3198 b
->addr_string
= strsave (buf
);
3200 /* now send notification command back to GUI */
3201 sprintf (buf
, "0x%x", sal
.pc
);
3202 a
[0] = Tcl_NewStringObj ("gdbtk_tcl_breakpoint create", -1);
3203 a
[1] = Tcl_NewIntObj (b
->number
);
3204 a
[2] = Tcl_NewStringObj (buf
, -1);
3206 a
[4] = Tcl_NewListObj (1,&objv
[1]);
3207 cmd
= Tcl_ConcatObj(5,a
);
3208 ret
= Tcl_EvalObj (interp
, cmd
);
3209 Tcl_DecrRefCount (cmd
);
3214 /* The whole timer idea is an easy one, but POSIX does not appear to have
3215 some sort of interval timer requirement. Consequently, we cannot rely
3216 on cygwin32 to always deliver the timer's signal. This is especially
3217 painful given that all serial I/O will block the timer right now. */
3219 gdbtk_annotate_starting ()
3221 /* TclDebug ("### STARTING ###"); */
3222 gdbtk_start_timer ();
3226 gdbtk_annotate_stopped ()
3228 /* TclDebug ("### STOPPED ###"); */
3229 gdbtk_stop_timer ();
3233 gdbtk_annotate_exited ()
3235 /* TclDebug ("### EXITED ###"); */
3236 gdbtk_stop_timer ();
3240 gdbtk_annotate_signalled ()
3242 /* TclDebug ("### SIGNALLED ###"); */
3243 gdbtk_stop_timer ();
3247 /* Come here during initialize_all_files () */
3250 _initialize_gdbtk ()
3254 /* Tell the rest of the world that Gdbtk is now set up. */
3256 init_ui_hook
= gdbtk_init
;