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"
44 /* start-sanitize-ide */
48 /* end-sanitize-ide */
51 #ifdef ANSI_PROTOTYPES
61 #include <sys/ioctl.h>
62 #include "gdb_string.h"
69 #include <sys/stropts.h>
78 #define GDBTK_PATH_SEP ";"
80 #define GDBTK_PATH_SEP ":"
83 /* Some versions (1.3.79, 1.3.81) of Linux don't support SIOCSPGRP the way
84 gdbtk wants to use it... */
89 static int load_in_progress
= 0;
91 int gdbtk_load_hash
PARAMS ((char *, unsigned long));
92 int (*ui_load_progress_hook
) PARAMS ((char *, unsigned long));
93 void (*pre_add_symbol_hook
) PARAMS ((char *));
94 void (*post_add_symbol_hook
) PARAMS ((void));
96 static void null_routine
PARAMS ((int));
97 static void gdbtk_flush
PARAMS ((FILE *));
98 static void gdbtk_fputs
PARAMS ((const char *, FILE *));
99 static int gdbtk_query
PARAMS ((const char *, va_list));
100 static char *gdbtk_readline
PARAMS ((char *));
101 static void gdbtk_init
PARAMS ((char *));
102 static void tk_command_loop
PARAMS ((void));
103 static void gdbtk_call_command
PARAMS ((struct cmd_list_element
*, char *, int));
104 static int gdbtk_wait
PARAMS ((int, struct target_waitstatus
*));
105 static void x_event
PARAMS ((int));
106 static void gdbtk_interactive
PARAMS ((void));
107 static void cleanup_init
PARAMS ((int));
108 static void tk_command
PARAMS ((char *, int));
109 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
110 static int compare_lines
PARAMS ((const PTR
, const PTR
));
111 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
112 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
113 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
114 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
115 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
116 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
117 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
118 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
119 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
120 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
121 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
122 static void gdbtk_readline_end
PARAMS ((void));
123 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
124 static void register_changed_p
PARAMS ((int, void *));
125 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
126 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
127 static void breakpoint_notify
PARAMS ((struct breakpoint
*, const char *));
128 static void gdbtk_create_breakpoint
PARAMS ((struct breakpoint
*));
129 static void gdbtk_delete_breakpoint
PARAMS ((struct breakpoint
*));
130 static void gdbtk_modify_breakpoint
PARAMS ((struct breakpoint
*));
131 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
132 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
133 static int gdb_sourcelines
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
134 static int map_arg_registers
PARAMS ((int, char *[], void (*) (int, void *), void *));
135 static void get_register_name
PARAMS ((int, void *));
136 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
137 static void get_register
PARAMS ((int, void *));
138 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
139 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
140 void TclDebug
PARAMS ((const char *fmt
, ...));
141 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
142 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
143 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
144 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
145 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
146 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
147 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
148 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
149 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
150 static char *find_file_in_dir
PARAMS ((char *));
151 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
152 static void gdbtk_create_tracepoint
PARAMS ((struct tracepoint
*));
153 static void gdbtk_delete_tracepoint
PARAMS ((struct tracepoint
*));
154 static void gdbtk_modify_tracepoint
PARAMS ((struct tracepoint
*));
155 static void tracepoint_notify
PARAMS ((struct tracepoint
*, const char *));
156 static void gdbtk_print_frame_info
PARAMS ((struct symtab
*, int, int, int));
157 void gdbtk_pre_add_symbol
PARAMS ((char *));
158 void gdbtk_post_add_symbol
PARAMS ((void));
160 /* Handle for TCL interpreter */
162 static Tcl_Interp
*interp
= NULL
;
165 static int x_fd
; /* X network socket */
170 /* On Windows we use timer interrupts when gdb might otherwise hang
171 for a long time. See the comment above gdbtk_start_timer. This
172 variable is true when timer interrupts are being used. */
174 static int gdbtk_timer_going
= 0;
176 static void gdbtk_start_timer
PARAMS ((void));
177 static void gdbtk_stop_timer
PARAMS ((void));
181 /* This variable is true when the inferior is running. Although it's
182 possible to disable most input from widgets and thus prevent
183 attempts to do anything while the inferior is running, any commands
184 that get through - even a simple memory read - are Very Bad, and
185 may cause GDB to crash or behave strangely. So, this variable
186 provides an extra layer of defense. */
188 static int running_now
;
190 /* This variable determines where memory used for disassembly is read from.
191 If > 0, then disassembly comes from the exec file rather than the
192 target (which might be at the other end of a slow serial link). If
193 == 0 then disassembly comes from target. If < 0 disassembly is
194 automatically switched to the target if it's an inferior process,
195 otherwise the exec file is used. */
197 static int disassemble_from_exec
= -1;
201 /* Supply malloc calls for tcl/tk. We do not want to do this on
202 Windows, because Tcl_Alloc is probably in a DLL which will not call
203 the mmalloc routines. */
209 return xmalloc (size
);
213 Tcl_Realloc (ptr
, size
)
217 return xrealloc (ptr
, size
);
227 #endif /* ! _WIN32 */
237 /* On Windows, if we hold a file open, other programs can't write to
238 it. In particular, we don't want to hold the executable open,
239 because it will mean that people have to get out of the debugging
240 session in order to remake their program. So we close it, although
241 this will cost us if and when we need to reopen it. */
251 bfd_cache_close (o
->obfd
);
254 if (exec_bfd
!= NULL
)
255 bfd_cache_close (exec_bfd
);
260 /* The following routines deal with stdout/stderr data, which is created by
261 {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the
262 lowest level of these routines and capture all output from the rest of GDB.
263 Normally they present their data to tcl via callbacks to the following tcl
264 routines: gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush. These
265 in turn call tk routines to update the display.
267 Under some circumstances, you may want to collect the output so that it can
268 be returned as the value of a tcl procedure. This can be done by
269 surrounding the output routines with calls to start_saving_output and
270 finish_saving_output. The saved data can then be retrieved with
271 get_saved_output (but this must be done before the call to
272 finish_saving_output). */
274 /* Dynamic string for output. */
276 static Tcl_DString
*result_ptr
;
278 /* Dynamic string for stderr. This is only used if result_ptr is
281 static Tcl_DString
*error_string_ptr
;
288 /* Force immediate screen update */
290 Tcl_VarEval (interp
, "gdbtk_tcl_flush", NULL
);
295 gdbtk_fputs (ptr
, stream
)
300 Tcl_DStringAppend (result_ptr
, (char *) ptr
, -1);
301 else if (error_string_ptr
!= NULL
&& stream
== gdb_stderr
)
302 Tcl_DStringAppend (error_string_ptr
, (char *) ptr
, -1);
307 Tcl_DStringInit (&str
);
309 Tcl_DStringAppend (&str
, "gdbtk_tcl_fputs", -1);
310 Tcl_DStringAppendElement (&str
, (char *)ptr
);
312 Tcl_Eval (interp
, Tcl_DStringValue (&str
));
313 Tcl_DStringFree (&str
);
318 gdbtk_query (query
, args
)
322 char buf
[200], *merge
[2];
326 vsprintf (buf
, query
, args
);
327 merge
[0] = "gdbtk_tcl_query";
329 command
= Tcl_Merge (2, merge
);
330 Tcl_Eval (interp
, command
);
333 val
= atol (interp
->result
);
339 #ifdef ANSI_PROTOTYPES
340 gdbtk_readline_begin (char *format
, ...)
342 gdbtk_readline_begin (va_alist
)
347 char buf
[200], *merge
[2];
350 #ifdef ANSI_PROTOTYPES
351 va_start (args
, format
);
355 format
= va_arg (args
, char *);
358 vsprintf (buf
, format
, args
);
359 merge
[0] = "gdbtk_tcl_readline_begin";
361 command
= Tcl_Merge (2, merge
);
362 Tcl_Eval (interp
, command
);
367 gdbtk_readline (prompt
)
378 merge
[0] = "gdbtk_tcl_readline";
380 command
= Tcl_Merge (2, merge
);
381 result
= Tcl_Eval (interp
, command
);
383 if (result
== TCL_OK
)
385 return (strdup (interp
-> result
));
389 gdbtk_fputs (interp
-> result
, gdb_stdout
);
390 gdbtk_fputs ("\n", gdb_stdout
);
396 gdbtk_readline_end ()
398 Tcl_Eval (interp
, "gdbtk_tcl_readline_end");
403 #ifdef ANSI_PROTOTYPES
404 dsprintf_append_element (Tcl_DString
*dsp
, char *format
, ...)
406 dsprintf_append_element (va_alist
)
413 #ifdef ANSI_PROTOTYPES
414 va_start (args
, format
);
420 dsp
= va_arg (args
, Tcl_DString
*);
421 format
= va_arg (args
, char *);
424 vsprintf (buf
, format
, args
);
426 Tcl_DStringAppendElement (dsp
, buf
);
430 gdb_path_conv (clientData
, interp
, argc
, argv
)
431 ClientData clientData
;
437 char pathname
[256], *ptr
;
439 error ("wrong # args");
440 cygwin32_conv_to_full_win32_path (argv
[1], pathname
);
441 for (ptr
= pathname
; *ptr
; ptr
++)
447 char *pathname
= argv
[1];
449 Tcl_DStringAppend (result_ptr
, pathname
, strlen(pathname
));
454 gdb_get_breakpoint_list (clientData
, interp
, argc
, argv
)
455 ClientData clientData
;
460 struct breakpoint
*b
;
461 extern struct breakpoint
*breakpoint_chain
;
464 error ("wrong # args");
466 for (b
= breakpoint_chain
; b
; b
= b
->next
)
467 if (b
->type
== bp_breakpoint
)
468 dsprintf_append_element (result_ptr
, "%d", b
->number
);
474 gdb_get_breakpoint_info (clientData
, interp
, argc
, argv
)
475 ClientData clientData
;
480 struct symtab_and_line sal
;
481 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
482 "finish", "watchpoint", "hardware watchpoint",
483 "read watchpoint", "access watchpoint",
484 "longjmp", "longjmp resume", "step resume",
485 "through sigtramp", "watchpoint scope",
487 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
488 struct command_line
*cmd
;
490 struct breakpoint
*b
;
491 extern struct breakpoint
*breakpoint_chain
;
492 char *funcname
, *filename
;
495 error ("wrong # args");
497 bpnum
= atoi (argv
[1]);
499 for (b
= breakpoint_chain
; b
; b
= b
->next
)
500 if (b
->number
== bpnum
)
503 if (!b
|| b
->type
!= bp_breakpoint
)
504 error ("Breakpoint #%d does not exist", bpnum
);
506 sal
= find_pc_line (b
->address
, 0);
508 filename
= symtab_to_filename (sal
.symtab
);
509 if (filename
== NULL
)
511 Tcl_DStringAppendElement (result_ptr
, filename
);
512 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
513 Tcl_DStringAppendElement (result_ptr
, funcname
);
514 dsprintf_append_element (result_ptr
, "%d", sal
.line
);
515 dsprintf_append_element (result_ptr
, "0x%lx", b
->address
);
516 Tcl_DStringAppendElement (result_ptr
, bptypes
[b
->type
]);
517 Tcl_DStringAppendElement (result_ptr
, b
->enable
== enabled
? "1" : "0");
518 Tcl_DStringAppendElement (result_ptr
, bpdisp
[b
->disposition
]);
519 dsprintf_append_element (result_ptr
, "%d", b
->ignore_count
);
521 Tcl_DStringStartSublist (result_ptr
);
522 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
523 Tcl_DStringAppendElement (result_ptr
, cmd
->line
);
524 Tcl_DStringEndSublist (result_ptr
);
526 Tcl_DStringAppendElement (result_ptr
, b
->cond_string
);
528 dsprintf_append_element (result_ptr
, "%d", b
->thread
);
529 dsprintf_append_element (result_ptr
, "%d", b
->hit_count
);
535 breakpoint_notify(b
, action
)
536 struct breakpoint
*b
;
541 struct symtab_and_line sal
;
544 if (b
->type
!= bp_breakpoint
)
547 /* We ensure that ACTION contains no special Tcl characters, so we
549 sal
= find_pc_line (b
->address
, 0);
550 filename
= symtab_to_filename (sal
.symtab
);
551 if (filename
== NULL
)
553 sprintf (buf
, "gdbtk_tcl_breakpoint %s %d 0x%lx %d {%s}", action
, b
->number
,
554 (long)b
->address
, sal
.line
, filename
);
556 v
= Tcl_Eval (interp
, buf
);
560 gdbtk_fputs (interp
->result
, gdb_stdout
);
561 gdbtk_fputs ("\n", gdb_stdout
);
566 gdbtk_create_breakpoint(b
)
567 struct breakpoint
*b
;
569 breakpoint_notify (b
, "create");
573 gdbtk_delete_breakpoint(b
)
574 struct breakpoint
*b
;
576 breakpoint_notify (b
, "delete");
580 gdbtk_modify_breakpoint(b
)
581 struct breakpoint
*b
;
583 breakpoint_notify (b
, "modify");
586 /* This implements the TCL command `gdb_loc', which returns a list consisting
587 of the source and line number associated with the current pc. */
590 gdb_loc (clientData
, interp
, argc
, argv
)
591 ClientData clientData
;
597 struct symtab_and_line sal
;
601 if (!have_full_symbols () && !have_partial_symbols ())
603 Tcl_SetResult (interp
, "No symbol table is loaded", TCL_STATIC
);
611 sal
= find_pc_line (selected_frame
->pc
,
612 selected_frame
->next
!= NULL
613 && !selected_frame
->next
->signal_handler_caller
614 && !frame_in_dummy (selected_frame
->next
));
617 sal
= find_pc_line (stop_pc
, 0);
621 struct symtabs_and_lines sals
;
624 sals
= decode_line_spec (argv
[1], 1);
631 error ("Ambiguous line spec");
634 error ("wrong # args");
638 Tcl_DStringAppendElement (result_ptr
, sal
.symtab
->filename
);
640 Tcl_DStringAppendElement (result_ptr
, "");
642 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
643 Tcl_DStringAppendElement (result_ptr
, funcname
);
645 filename
= symtab_to_filename (sal
.symtab
);
646 if (filename
== NULL
)
649 Tcl_DStringAppendElement (result_ptr
, filename
);
650 dsprintf_append_element (result_ptr
, "%d", sal
.line
); /* line number */
651 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
652 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
656 /* This implements the TCL command `gdb_eval'. */
659 gdb_eval (clientData
, interp
, argc
, argv
)
660 ClientData clientData
;
665 struct expression
*expr
;
666 struct cleanup
*old_chain
;
670 error ("wrong # args");
672 expr
= parse_expression (argv
[1]);
674 old_chain
= make_cleanup (free_current_contents
, &expr
);
676 val
= evaluate_expression (expr
);
678 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
679 gdb_stdout
, 0, 0, 0, 0);
681 do_cleanups (old_chain
);
686 /* gdb_get_mem addr form size num aschar*/
687 /* dump a block of memory */
688 /* addr: address of data to dump */
689 /* form: a char indicating format */
690 /* size: size of each element; 1,2,4, or 8 bytes*/
691 /* num: the number of 'size' elements to return */
692 /* acshar: an optional ascii character to use in ASCII dump */
693 /* returns a list of 'num' elements followed by an optional */
696 gdb_get_mem (clientData
, interp
, argc
, argv
)
697 ClientData clientData
;
702 int size
, asize
, num
, i
, j
;
703 CORE_ADDR addr
, saved_addr
, ptr
;
705 struct type
*val_type
;
707 char c
, buff
[128], aschar
;
710 error ("wrong # args");
712 addr
= (CORE_ADDR
)strtoul(argv
[1],(char **)NULL
,0);
715 size
= (int)strtoul(argv
[3],(char **)NULL
,0);
716 num
= (int)strtoul(argv
[4],(char **)NULL
,0);
721 val_type
= builtin_type_char
;
725 val_type
= builtin_type_short
;
729 val_type
= builtin_type_int
;
733 val_type
= builtin_type_long_long
;
737 val_type
= builtin_type_char
;
741 for (i
=0; i
< num
; i
++)
743 vptr
= value_at (val_type
, addr
, (asection
*)NULL
);
744 print_scalar_formatted (VALUE_CONTENTS(vptr
), val_type
, format
, asize
, gdb_stdout
);
745 fputs_unfiltered (" ", gdb_stdout
);
751 val_type
= builtin_type_char
;
755 for (j
=0; j
< num
*size
; j
++)
757 c
= *(char *)VALUE_CONTENTS(value_at (val_type
, ptr
, (asection
*)NULL
));
758 if (c
< 32 || c
> 126)
767 fputs_unfiltered (buff
, gdb_stdout
);
774 /* This implements the TCL command `gdb_sourcelines', which returns a list of
775 all of the lines containing executable code for the specified source file
776 (ie: lines where you can put breakpoints). */
779 gdb_sourcelines (clientData
, interp
, argc
, argv
)
780 ClientData clientData
;
785 struct symtab
*symtab
;
786 struct linetable_entry
*le
;
790 error ("wrong # args");
792 symtab
= lookup_symtab (argv
[1]);
795 error ("No such file");
797 /* If there's no linetable, or no entries, then we are done. */
799 if (!symtab
->linetable
800 || symtab
->linetable
->nitems
== 0)
802 Tcl_DStringAppendElement (result_ptr
, "");
806 le
= symtab
->linetable
->item
;
807 nlines
= symtab
->linetable
->nitems
;
809 for (;nlines
> 0; nlines
--, le
++)
811 /* If the pc of this line is the same as the pc of the next line, then
814 && le
->pc
== (le
+ 1)->pc
)
817 dsprintf_append_element (result_ptr
, "%d", le
->line
);
824 map_arg_registers (argc
, argv
, func
, argp
)
827 void (*func
) PARAMS ((int regnum
, void *argp
));
832 /* Note that the test for a valid register must include checking the
833 reg_names array because NUM_REGS may be allocated for the union of the
834 register sets within a family of related processors. In this case, the
835 trailing entries of reg_names will change depending upon the particular
836 processor being debugged. */
838 if (argc
== 0) /* No args, just do all the regs */
842 && reg_names
[regnum
] != NULL
843 && *reg_names
[regnum
] != '\000';
850 /* Else, list of register #s, just do listed regs */
851 for (; argc
> 0; argc
--, argv
++)
853 regnum
= atoi (*argv
);
857 && reg_names
[regnum
] != NULL
858 && *reg_names
[regnum
] != '\000')
861 error ("bad register number");
868 get_register_name (regnum
, argp
)
870 void *argp
; /* Ignored */
872 Tcl_DStringAppendElement (result_ptr
, reg_names
[regnum
]);
875 /* This implements the TCL command `gdb_regnames', which returns a list of
876 all of the register names. */
879 gdb_regnames (clientData
, interp
, argc
, argv
)
880 ClientData clientData
;
888 return map_arg_registers (argc
, argv
, get_register_name
, NULL
);
891 #ifndef REGISTER_CONVERTIBLE
892 #define REGISTER_CONVERTIBLE(x) (0 != 0)
895 #ifndef REGISTER_CONVERT_TO_VIRTUAL
896 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
899 #ifndef INVALID_FLOAT
900 #define INVALID_FLOAT(x, y) (0 != 0)
904 get_register (regnum
, fp
)
908 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
909 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
910 int format
= (int)fp
;
912 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
914 Tcl_DStringAppendElement (result_ptr
, "Optimized out");
918 /* Convert raw data to virtual format if necessary. */
920 if (REGISTER_CONVERTIBLE (regnum
))
922 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
923 raw_buffer
, virtual_buffer
);
926 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
931 printf_filtered ("0x");
932 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
934 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
935 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
936 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
940 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
941 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
943 Tcl_DStringAppend (result_ptr
, " ", -1);
947 gdb_fetch_registers (clientData
, interp
, argc
, argv
)
948 ClientData clientData
;
956 error ("wrong # args");
964 return map_arg_registers (argc
, argv
, get_register
, (void *) format
);
967 /* This contains the previous values of the registers, since the last call to
968 gdb_changed_register_list. */
970 static char old_regs
[REGISTER_BYTES
];
973 register_changed_p (regnum
, argp
)
975 void *argp
; /* Ignored */
977 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
979 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
982 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
983 REGISTER_RAW_SIZE (regnum
)) == 0)
986 /* Found a changed register. Save new value and return its number. */
988 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
989 REGISTER_RAW_SIZE (regnum
));
991 dsprintf_append_element (result_ptr
, "%d", regnum
);
995 gdb_changed_register_list (clientData
, interp
, argc
, argv
)
996 ClientData clientData
;
1004 return map_arg_registers (argc
, argv
, register_changed_p
, NULL
);
1007 /* This implements the tcl command "gdb_immediate", which does exactly
1008 the same thing as gdb_cmd, except NONE of its outut is buffered. */
1010 gdb_immediate_command (clientData
, interp
, argc
, argv
)
1011 ClientData clientData
;
1016 Tcl_DString
*save_ptr
= NULL
;
1019 error ("wrong # args");
1024 Tcl_DStringAppend (result_ptr
, "", -1);
1025 save_ptr
= result_ptr
;
1028 execute_command (argv
[1], 1);
1030 bpstat_do_actions (&stop_bpstat
);
1032 result_ptr
= save_ptr
;
1037 /* This implements the TCL command `gdb_cmd', which sends its argument into
1038 the GDB command scanner. */
1041 gdb_cmd (clientData
, interp
, argc
, argv
)
1042 ClientData clientData
;
1047 Tcl_DString
*save_ptr
= NULL
;
1050 error ("wrong # args");
1055 /* for the load instruction (and possibly others later) we
1056 set result_ptr to NULL so gdbtk_fputs() will not buffer
1057 all the data until the command is finished. */
1059 if (strncmp ("load ", argv
[1], 5) == 0
1060 || strncmp ("while ", argv
[1], 6) == 0)
1062 Tcl_DStringAppend (result_ptr
, "", -1);
1063 save_ptr
= result_ptr
;
1065 load_in_progress
= 1;
1067 /* On Windows, use timer interrupts so that the user can cancel
1068 the download. FIXME: We may have to do something on other
1071 gdbtk_start_timer ();
1075 execute_command (argv
[1], 1);
1078 if (load_in_progress
)
1079 gdbtk_stop_timer ();
1082 load_in_progress
= 0;
1083 bpstat_do_actions (&stop_bpstat
);
1086 result_ptr
= save_ptr
;
1091 /* Client of call_wrapper - this routine performs the actual call to
1092 the client function. */
1094 struct wrapped_call_args
1105 struct wrapped_call_args
*args
;
1107 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->argc
, args
->argv
);
1111 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
1112 handles cleanups, and calls to return_to_top_level (usually via error).
1113 This is necessary in order to prevent a longjmp out of the bowels of Tk,
1114 possibly leaving things in a bad state. Since this routine can be called
1115 recursively, it needs to save and restore the contents of the jmp_buf as
1119 call_wrapper (clientData
, interp
, argc
, argv
)
1120 ClientData clientData
;
1125 struct wrapped_call_args wrapped_args
;
1126 Tcl_DString result
, *old_result_ptr
;
1127 Tcl_DString error_string
, *old_error_string_ptr
;
1129 Tcl_DStringInit (&result
);
1130 old_result_ptr
= result_ptr
;
1131 result_ptr
= &result
;
1133 Tcl_DStringInit (&error_string
);
1134 old_error_string_ptr
= error_string_ptr
;
1135 error_string_ptr
= &error_string
;
1137 wrapped_args
.func
= (Tcl_CmdProc
*)clientData
;
1138 wrapped_args
.interp
= interp
;
1139 wrapped_args
.argc
= argc
;
1140 wrapped_args
.argv
= argv
;
1141 wrapped_args
.val
= 0;
1143 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
1145 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
1148 /* Make sure the timer interrupts are turned off. */
1149 if (gdbtk_timer_going
)
1150 gdbtk_stop_timer ();
1153 gdb_flush (gdb_stderr
); /* Flush error output */
1154 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
1156 /* In case of an error, we may need to force the GUI into idle
1157 mode because gdbtk_call_command may have bombed out while in
1158 the command routine. */
1161 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1164 /* if the download was cancelled, don't print the error */
1165 if (load_in_progress
)
1167 Tcl_DStringInit (&error_string
);
1168 wrapped_args
.val
= TCL_OK
;
1169 load_in_progress
= 0;
1172 if (Tcl_DStringLength (&error_string
) == 0)
1174 Tcl_DStringResult (interp
, &result
);
1175 Tcl_DStringFree (&error_string
);
1177 else if (Tcl_DStringLength (&result
) == 0)
1179 Tcl_DStringResult (interp
, &error_string
);
1180 Tcl_DStringFree (&result
);
1181 Tcl_DStringFree (&error_string
);
1185 Tcl_ResetResult (interp
);
1186 Tcl_AppendResult (interp
, Tcl_DStringValue (&result
),
1187 Tcl_DStringValue (&error_string
), (char *) NULL
);
1188 Tcl_DStringFree (&result
);
1189 Tcl_DStringFree (&error_string
);
1192 result_ptr
= old_result_ptr
;
1193 error_string_ptr
= old_error_string_ptr
;
1199 return wrapped_args
.val
;
1203 comp_files (file1
, file2
)
1204 const char *file1
[], *file2
[];
1206 return strcmp(*file1
,*file2
);
1211 gdb_listfiles (clientData
, interp
, objc
, objv
)
1212 ClientData clientData
;
1215 Tcl_Obj
*CONST objv
[];
1217 struct objfile
*objfile
;
1218 struct partial_symtab
*psymtab
;
1219 struct symtab
*symtab
;
1220 char *lastfile
, *pathname
, *files
[1000];
1221 int i
, numfiles
= 0, len
= 0;
1226 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1230 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1232 mylist
= Tcl_NewListObj (0, NULL
);
1234 ALL_PSYMTABS (objfile
, psymtab
)
1238 if (psymtab
->filename
)
1239 files
[numfiles
++] = basename(psymtab
->filename
);
1241 else if (!strcmp(psymtab
->filename
,basename(psymtab
->filename
))
1242 || !strncmp(pathname
,psymtab
->filename
,len
))
1243 if (psymtab
->filename
)
1244 files
[numfiles
++] = basename(psymtab
->filename
);
1247 ALL_SYMTABS (objfile
, symtab
)
1251 if (symtab
->filename
)
1252 files
[numfiles
++] = basename(symtab
->filename
);
1254 else if (!strcmp(symtab
->filename
,basename(symtab
->filename
))
1255 || !strncmp(pathname
,symtab
->filename
,len
))
1256 if (symtab
->filename
)
1257 files
[numfiles
++] = basename(symtab
->filename
);
1260 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1263 for (i
= 0; i
< numfiles
; i
++)
1265 if (strcmp(files
[i
],lastfile
))
1266 Tcl_ListObjAppendElement (interp
, mylist
, Tcl_NewStringObj(files
[i
], -1));
1267 lastfile
= files
[i
];
1269 Tcl_SetObjResult (interp
, mylist
);
1274 gdb_listfuncs (clientData
, interp
, argc
, argv
)
1275 ClientData clientData
;
1280 struct symtab
*symtab
;
1281 struct blockvector
*bv
;
1287 error ("wrong # args");
1289 symtab
= lookup_symtab (argv
[1]);
1292 error ("No such file");
1294 bv
= BLOCKVECTOR (symtab
);
1295 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1297 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1298 /* Skip the sort if this block is always sorted. */
1299 if (!BLOCK_SHOULD_SORT (b
))
1300 sort_block_syms (b
);
1301 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1303 sym
= BLOCK_SYM (b
, j
);
1304 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1306 Tcl_DStringAppendElement (result_ptr
, SYMBOL_NAME(sym
));
1314 gdb_stop (clientData
, interp
, argc
, argv
)
1315 ClientData clientData
;
1323 quit_flag
= 1; /* hope something sees this */
1328 /* Prepare to accept a new executable file. This is called when we
1329 want to clear away everything we know about the old file, without
1330 asking the user. The Tcl code will have already asked the user if
1331 necessary. After this is called, we should be able to run the
1332 `file' command without getting any questions. */
1335 gdb_clear_file (clientData
, interp
, argc
, argv
)
1336 ClientData clientData
;
1341 if (inferior_pid
!= 0 && target_has_execution
)
1344 target_detach (NULL
, 0);
1349 if (target_has_execution
)
1352 symbol_file_command (NULL
, 0);
1354 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
1355 clear it here. FIXME: This seems like an abstraction violation
1362 /* Ask the user to confirm an exit request. */
1365 gdb_confirm_quit (clientData
, interp
, argc
, argv
)
1366 ClientData clientData
;
1373 ret
= quit_confirm ();
1374 Tcl_DStringAppendElement (result_ptr
, ret
? "1" : "0");
1378 /* Quit without asking for confirmation. */
1381 gdb_force_quit (clientData
, interp
, argc
, argv
)
1382 ClientData clientData
;
1387 quit_force ((char *) NULL
, 1);
1391 /* This implements the TCL command `gdb_disassemble'. */
1394 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
1398 disassemble_info
*info
;
1400 extern struct target_ops exec_ops
;
1404 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
1415 /* We need a different sort of line table from the normal one cuz we can't
1416 depend upon implicit line-end pc's for lines. This is because of the
1417 reordering we are about to do. */
1419 struct my_line_entry
{
1426 compare_lines (mle1p
, mle2p
)
1430 struct my_line_entry
*mle1
, *mle2
;
1433 mle1
= (struct my_line_entry
*) mle1p
;
1434 mle2
= (struct my_line_entry
*) mle2p
;
1436 val
= mle1
->line
- mle2
->line
;
1441 return mle1
->start_pc
- mle2
->start_pc
;
1445 gdb_disassemble (clientData
, interp
, argc
, argv
)
1446 ClientData clientData
;
1451 CORE_ADDR pc
, low
, high
;
1452 int mixed_source_and_assembly
;
1453 static disassemble_info di
;
1454 static int di_initialized
;
1456 if (! di_initialized
)
1458 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
1459 (fprintf_ftype
) fprintf_unfiltered
);
1460 di
.flavour
= bfd_target_unknown_flavour
;
1461 di
.memory_error_func
= dis_asm_memory_error
;
1462 di
.print_address_func
= dis_asm_print_address
;
1466 di
.mach
= tm_print_insn_info
.mach
;
1467 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
1468 di
.endian
= BFD_ENDIAN_BIG
;
1470 di
.endian
= BFD_ENDIAN_LITTLE
;
1472 if (argc
!= 3 && argc
!= 4)
1473 error ("wrong # args");
1475 if (strcmp (argv
[1], "source") == 0)
1476 mixed_source_and_assembly
= 1;
1477 else if (strcmp (argv
[1], "nosource") == 0)
1478 mixed_source_and_assembly
= 0;
1480 error ("First arg must be 'source' or 'nosource'");
1482 low
= parse_and_eval_address (argv
[2]);
1486 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
1487 error ("No function contains specified address");
1490 high
= parse_and_eval_address (argv
[3]);
1492 /* If disassemble_from_exec == -1, then we use the following heuristic to
1493 determine whether or not to do disassembly from target memory or from the
1496 If we're debugging a local process, read target memory, instead of the
1497 exec file. This makes disassembly of functions in shared libs work
1500 Else, we're debugging a remote process, and should disassemble from the
1501 exec file for speed. However, this is no good if the target modifies its
1502 code (for relocation, or whatever).
1505 if (disassemble_from_exec
== -1)
1506 if (strcmp (target_shortname
, "child") == 0
1507 || strcmp (target_shortname
, "procfs") == 0
1508 || strcmp (target_shortname
, "vxprocess") == 0)
1509 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
1511 disassemble_from_exec
= 1; /* It's remote, read the exec file */
1513 if (disassemble_from_exec
)
1514 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
1516 di
.read_memory_func
= dis_asm_read_memory
;
1518 /* If just doing straight assembly, all we need to do is disassemble
1519 everything between low and high. If doing mixed source/assembly, we've
1520 got a totally different path to follow. */
1522 if (mixed_source_and_assembly
)
1523 { /* Come here for mixed source/assembly */
1524 /* The idea here is to present a source-O-centric view of a function to
1525 the user. This means that things are presented in source order, with
1526 (possibly) out of order assembly immediately following. */
1527 struct symtab
*symtab
;
1528 struct linetable_entry
*le
;
1531 struct my_line_entry
*mle
;
1532 struct symtab_and_line sal
;
1537 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
1542 /* First, convert the linetable to a bunch of my_line_entry's. */
1544 le
= symtab
->linetable
->item
;
1545 nlines
= symtab
->linetable
->nitems
;
1550 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
1554 /* Copy linetable entries for this function into our data structure, creating
1555 end_pc's and setting out_of_order as appropriate. */
1557 /* First, skip all the preceding functions. */
1559 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
1561 /* Now, copy all entries before the end of this function. */
1564 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
1566 if (le
[i
].line
== le
[i
+ 1].line
1567 && le
[i
].pc
== le
[i
+ 1].pc
)
1568 continue; /* Ignore duplicates */
1570 mle
[newlines
].line
= le
[i
].line
;
1571 if (le
[i
].line
> le
[i
+ 1].line
)
1573 mle
[newlines
].start_pc
= le
[i
].pc
;
1574 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
1578 /* If we're on the last line, and it's part of the function, then we need to
1579 get the end pc in a special way. */
1584 mle
[newlines
].line
= le
[i
].line
;
1585 mle
[newlines
].start_pc
= le
[i
].pc
;
1586 sal
= find_pc_line (le
[i
].pc
, 0);
1587 mle
[newlines
].end_pc
= sal
.end
;
1591 /* Now, sort mle by line #s (and, then by addresses within lines). */
1594 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
1596 /* Now, for each line entry, emit the specified lines (unless they have been
1597 emitted before), followed by the assembly code for that line. */
1599 next_line
= 0; /* Force out first line */
1600 for (i
= 0; i
< newlines
; i
++)
1602 /* Print out everything from next_line to the current line. */
1604 if (mle
[i
].line
>= next_line
)
1607 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
1609 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
1611 next_line
= mle
[i
].line
+ 1;
1614 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
1617 fputs_unfiltered (" ", gdb_stdout
);
1618 print_address (pc
, gdb_stdout
);
1619 fputs_unfiltered (":\t ", gdb_stdout
);
1620 pc
+= (*tm_print_insn
) (pc
, &di
);
1621 fputs_unfiltered ("\n", gdb_stdout
);
1628 for (pc
= low
; pc
< high
; )
1631 fputs_unfiltered (" ", gdb_stdout
);
1632 print_address (pc
, gdb_stdout
);
1633 fputs_unfiltered (":\t ", gdb_stdout
);
1634 pc
+= (*tm_print_insn
) (pc
, &di
);
1635 fputs_unfiltered ("\n", gdb_stdout
);
1639 gdb_flush (gdb_stdout
);
1645 tk_command (cmd
, from_tty
)
1651 struct cleanup
*old_chain
;
1653 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1655 error_no_arg ("tcl command to interpret");
1657 retval
= Tcl_Eval (interp
, cmd
);
1659 result
= strdup (interp
->result
);
1661 old_chain
= make_cleanup (free
, result
);
1663 if (retval
!= TCL_OK
)
1666 printf_unfiltered ("%s\n", result
);
1668 do_cleanups (old_chain
);
1672 cleanup_init (ignored
)
1676 Tcl_DeleteInterp (interp
);
1680 /* Come here during long calculations to check for GUI events. Usually invoked
1681 via the QUIT macro. */
1684 gdbtk_interactive ()
1686 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1689 /* Come here when there is activity on the X file descriptor. */
1695 /* Process pending events */
1697 while (Tcl_DoOneEvent (TCL_DONT_WAIT
|TCL_ALL_EVENTS
) != 0)
1700 /* If we are doing a download, see if the download should be
1701 cancelled. FIXME: We should use a better variable name. */
1702 if (load_in_progress
)
1706 val
= Tcl_GetVar (interp
, "download_cancel_ok", TCL_GLOBAL_ONLY
);
1707 if (val
!= NULL
&& atoi (val
))
1722 /* For Cygwin32, we use a timer to periodically check for Windows
1723 messages. FIXME: It would be better to not poll, but to instead
1724 rewrite the target_wait routines to serve as input sources.
1725 Unfortunately, that will be a lot of work. */
1728 gdbtk_start_timer ()
1730 sigset_t nullsigmask
;
1731 struct sigaction action
;
1732 struct itimerval it
;
1734 sigemptyset (&nullsigmask
);
1736 action
.sa_handler
= x_event
;
1737 action
.sa_mask
= nullsigmask
;
1738 action
.sa_flags
= 0;
1739 sigaction (SIGALRM
, &action
, NULL
);
1741 it
.it_interval
.tv_sec
= 0;
1742 /* Check for messages twice a second. */
1743 it
.it_interval
.tv_usec
= 500 * 1000;
1744 it
.it_value
.tv_sec
= 0;
1745 it
.it_value
.tv_usec
= 500 * 1000;
1747 setitimer (ITIMER_REAL
, &it
, NULL
);
1749 gdbtk_timer_going
= 1;
1755 sigset_t nullsigmask
;
1756 struct sigaction action
;
1757 struct itimerval it
;
1759 gdbtk_timer_going
= 0;
1761 sigemptyset (&nullsigmask
);
1763 action
.sa_handler
= SIG_IGN
;
1764 action
.sa_mask
= nullsigmask
;
1765 action
.sa_flags
= 0;
1766 sigaction (SIGALRM
, &action
, NULL
);
1768 it
.it_interval
.tv_sec
= 0;
1769 it
.it_interval
.tv_usec
= 0;
1770 it
.it_value
.tv_sec
= 0;
1771 it
.it_value
.tv_usec
= 0;
1772 setitimer (ITIMER_REAL
, &it
, NULL
);
1777 /* This hook function is called whenever we want to wait for the
1781 gdbtk_wait (pid
, ourstatus
)
1783 struct target_waitstatus
*ourstatus
;
1786 struct sigaction action
;
1787 static sigset_t nullsigmask
= {0};
1791 /* Needed for SunOS 4.1.x */
1792 #define SA_RESTART 0
1795 action
.sa_handler
= x_event
;
1796 action
.sa_mask
= nullsigmask
;
1797 action
.sa_flags
= SA_RESTART
;
1798 sigaction(SIGIO
, &action
, NULL
);
1802 /* Call x_event ourselves now, as well as starting the timer;
1803 otherwise, if single stepping, we may never wait long enough for
1804 the timer to trigger. */
1807 gdbtk_start_timer ();
1810 pid
= target_wait (pid
, ourstatus
);
1813 gdbtk_stop_timer ();
1817 action
.sa_handler
= SIG_IGN
;
1818 sigaction(SIGIO
, &action
, NULL
);
1824 /* This is called from execute_command, and provides a wrapper around
1825 various command routines in a place where both protocol messages and
1826 user input both flow through. Mostly this is used for indicating whether
1827 the target process is running or not.
1831 gdbtk_call_command (cmdblk
, arg
, from_tty
)
1832 struct cmd_list_element
*cmdblk
;
1837 if (cmdblk
->class == class_run
|| cmdblk
->class == class_trace
)
1840 Tcl_Eval (interp
, "gdbtk_tcl_busy");
1841 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1843 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1846 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1849 /* This function is called instead of gdb's internal command loop. This is the
1850 last chance to do anything before entering the main Tk event loop. */
1855 extern GDB_FILE
*instream
;
1857 /* We no longer want to use stdin as the command input stream */
1860 if (Tcl_Eval (interp
, "gdbtk_tcl_preloop") != TCL_OK
)
1864 /* Force errorInfo to be set up propertly. */
1865 Tcl_AddErrorInfo (interp
, "");
1867 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
1869 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
1871 fputs_unfiltered (msg
, gdb_stderr
);
1882 /* gdbtk_init installs this function as a final cleanup. */
1885 gdbtk_cleanup (dummy
)
1891 /* Initialize gdbtk. */
1894 gdbtk_init ( argv0
)
1897 struct cleanup
*old_chain
;
1898 char *lib
, *gdbtk_lib
, *gdbtk_lib_tmp
, *gdbtk_file
;
1901 struct sigaction action
;
1902 static sigset_t nullsigmask
= {0};
1905 /* start-sanitize-ide */
1906 struct ide_event_handle
*h
;
1909 /* end-sanitize-ide */
1912 /* If there is no DISPLAY environment variable, Tk_Init below will fail,
1913 causing gdb to abort. If instead we simply return here, gdb will
1914 gracefully degrade to using the command line interface. */
1917 if (getenv ("DISPLAY") == NULL
)
1921 old_chain
= make_cleanup (cleanup_init
, 0);
1923 /* First init tcl and tk. */
1924 Tcl_FindExecutable (argv0
);
1925 interp
= Tcl_CreateInterp ();
1928 error ("Tcl_CreateInterp failed");
1930 if (Tcl_Init(interp
) != TCL_OK
)
1931 error ("Tcl_Init failed: %s", interp
->result
);
1933 make_final_cleanup (gdbtk_cleanup
, NULL
);
1935 /* Initialize the Paths variable. */
1936 if (ide_initialize_paths (interp
, "gdbtcl") != TCL_OK
)
1937 error ("ide_initialize_paths failed: %s", interp
->result
);
1940 /* start-sanitize-ide */
1941 /* Find the directory where we expect to find idemanager. We ignore
1942 errors since it doesn't really matter if this fails. */
1943 libexecdir
= Tcl_GetVar2 (interp
, "Paths", "libexecdir", TCL_GLOBAL_ONLY
);
1947 h
= ide_event_init_from_environment (&errmsg
, libexecdir
);
1950 Tcl_AppendResult (interp
, "can't initialize event system: ", errmsg
,
1952 fprintf(stderr
, "WARNING: ide_event_init_client failed: %s\n", interp
->result
);
1954 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
1958 if (ide_create_tclevent_command (interp
, h
) != TCL_OK
)
1959 error ("ide_create_tclevent_command failed: %s", interp
->result
);
1961 if (ide_create_edit_command (interp
, h
) != TCL_OK
)
1962 error ("ide_create_edit_command failed: %s", interp
->result
);
1964 if (ide_create_property_command (interp
, h
) != TCL_OK
)
1965 error ("ide_create_property_command failed: %s", interp
->result
);
1967 if (ide_create_build_command (interp
, h
) != TCL_OK
)
1968 error ("ide_create_build_command failed: %s", interp
->result
);
1970 if (ide_create_window_register_command (interp
, h
, "gdb-restore")
1972 error ("ide_create_window_register_command failed: %s",
1975 if (ide_create_window_command (interp
, h
) != TCL_OK
)
1976 error ("ide_create_window_command failed: %s", interp
->result
);
1978 if (ide_create_exit_command (interp
, h
) != TCL_OK
)
1979 error ("ide_create_exit_command failed: %s", interp
->result
);
1981 if (ide_create_help_command (interp
) != TCL_OK
)
1982 error ("ide_create_help_command failed: %s", interp
->result
);
1985 if (ide_initialize (interp, "gdb") != TCL_OK)
1986 error ("ide_initialize failed: %s", interp->result);
1989 Tcl_SetVar (interp
, "GDBTK_IDE", "1", 0);
1990 Tcl_SetVar (interp
, "IDE", "1", TCL_GLOBAL_ONLY
);
1992 /* end-sanitize-ide */
1994 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
1997 /* We don't want to open the X connection until we've done all the
1998 IDE initialization. Otherwise, goofy looking unfinished windows
1999 pop up when ILU drops into the TCL event loop. */
2001 if (Tk_Init(interp
) != TCL_OK
)
2002 error ("Tk_Init failed: %s", interp
->result
);
2004 if (Itcl_Init(interp
) == TCL_ERROR
)
2005 error ("Itcl_Init failed: %s", interp
->result
);
2007 if (Tix_Init(interp
) != TCL_OK
)
2008 error ("Tix_Init failed: %s", interp
->result
);
2011 /* On Windows, create a sizebox widget command */
2012 if (ide_create_sizebox_command (interp
) != TCL_OK
)
2013 error ("sizebox creation failed");
2014 if (ide_create_winprint_command (interp
) != TCL_OK
)
2015 error ("windows print code initialization failed");
2016 /* start-sanitize-ide */
2017 /* An interface to ShellExecute. */
2018 if (ide_create_shell_execute_command (interp
) != TCL_OK
)
2019 error ("shell execute command initialization failed");
2020 /* end-sanitize-ide */
2023 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
2024 Tcl_CreateCommand (interp
, "gdb_immediate", call_wrapper
,
2025 gdb_immediate_command
, NULL
);
2026 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
2027 Tcl_CreateCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
2028 Tcl_CreateCommand (interp
, "gdb_sourcelines", call_wrapper
, gdb_sourcelines
,
2030 Tcl_CreateObjCommand (interp
, "gdb_listfiles", gdb_listfiles
, NULL
, NULL
);
2031 Tcl_CreateCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
2033 Tcl_CreateCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
2035 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
2036 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
2037 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
2038 gdb_fetch_registers
, NULL
);
2039 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
2040 gdb_changed_register_list
, NULL
);
2041 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
2042 gdb_disassemble
, NULL
);
2043 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
2044 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
2045 gdb_get_breakpoint_list
, NULL
);
2046 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
2047 gdb_get_breakpoint_info
, NULL
);
2048 Tcl_CreateCommand (interp
, "gdb_clear_file", call_wrapper
,
2049 gdb_clear_file
, NULL
);
2050 Tcl_CreateCommand (interp
, "gdb_confirm_quit", call_wrapper
,
2051 gdb_confirm_quit
, NULL
);
2052 Tcl_CreateCommand (interp
, "gdb_force_quit", call_wrapper
,
2053 gdb_force_quit
, NULL
);
2054 Tcl_CreateCommand (interp
, "gdb_target_has_execution",
2055 gdb_target_has_execution_command
,
2057 Tcl_CreateObjCommand (interp
, "gdb_load_info", gdb_load_info
, NULL
, NULL
);
2058 Tcl_CreateObjCommand (interp
, "gdb_get_locals", gdb_get_vars_command
,
2059 (ClientData
) 0, NULL
);
2060 Tcl_CreateObjCommand (interp
, "gdb_get_args", gdb_get_vars_command
,
2061 (ClientData
) 1, NULL
);
2062 Tcl_CreateObjCommand (interp
, "gdb_get_function", gdb_get_function_command
,
2064 Tcl_CreateObjCommand (interp
, "gdb_get_line", gdb_get_line_command
,
2066 Tcl_CreateObjCommand (interp
, "gdb_get_file", gdb_get_file_command
,
2068 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
2069 gdb_tracepoint_exists_command
, NULL
, NULL
);
2070 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
2071 gdb_get_tracepoint_info
, NULL
, NULL
);
2072 Tcl_CreateObjCommand (interp
, "gdb_actions",
2073 gdb_actions_command
, NULL
, NULL
);
2074 Tcl_CreateObjCommand (interp
, "gdb_prompt",
2075 gdb_prompt_command
, NULL
, NULL
);
2076 Tcl_CreateObjCommand (interp
, "gdb_find_file",
2077 gdb_find_file_command
, NULL
, NULL
);
2078 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
2079 gdb_get_tracepoint_list
, NULL
, NULL
);
2081 command_loop_hook
= tk_command_loop
;
2082 print_frame_info_listing_hook
= gdbtk_print_frame_info
;
2083 query_hook
= gdbtk_query
;
2084 flush_hook
= gdbtk_flush
;
2085 create_breakpoint_hook
= gdbtk_create_breakpoint
;
2086 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
2087 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
2088 interactive_hook
= gdbtk_interactive
;
2089 target_wait_hook
= gdbtk_wait
;
2090 call_command_hook
= gdbtk_call_command
;
2091 readline_begin_hook
= gdbtk_readline_begin
;
2092 readline_hook
= gdbtk_readline
;
2093 readline_end_hook
= gdbtk_readline_end
;
2094 ui_load_progress_hook
= gdbtk_load_hash
;
2095 pre_add_symbol_hook
= gdbtk_pre_add_symbol
;
2096 post_add_symbol_hook
= gdbtk_post_add_symbol
;
2097 create_tracepoint_hook
= gdbtk_create_tracepoint
;
2098 delete_tracepoint_hook
= gdbtk_delete_tracepoint
;
2099 modify_tracepoint_hook
= gdbtk_modify_tracepoint
;
2102 /* Get the file descriptor for the X server */
2104 x_fd
= ConnectionNumber (Tk_Display (Tk_MainWindow (interp
)));
2106 /* Setup for I/O interrupts */
2108 action
.sa_mask
= nullsigmask
;
2109 action
.sa_flags
= 0;
2110 action
.sa_handler
= SIG_IGN
;
2111 sigaction(SIGIO
, &action
, NULL
);
2115 if (ioctl (x_fd
, FIOASYNC
, &i
))
2116 perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
2120 if (ioctl (x_fd
, SIOCSPGRP
, &i
))
2121 perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
2126 if (fcntl (x_fd
, F_SETOWN
, i
))
2127 perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
2128 #endif /* F_SETOWN */
2129 #endif /* !SIOCSPGRP */
2132 if (ioctl (x_fd
, I_SETSIG
, S_INPUT
|S_RDNORM
) < 0)
2133 perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
2136 #endif /* ifndef FIOASYNC */
2139 add_com ("tk", class_obscure
, tk_command
,
2140 "Send a command directly into tk.");
2142 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
2145 /* find the gdb tcl library and source main.tcl */
2147 gdbtk_lib
= getenv ("GDBTK_LIBRARY");
2149 if (access ("gdbtcl/main.tcl", R_OK
) == 0)
2150 gdbtk_lib
= "gdbtcl";
2152 gdbtk_lib
= GDBTK_LIBRARY
;
2154 gdbtk_lib_tmp
= xstrdup (gdbtk_lib
);
2157 /* see if GDBTK_LIBRARY is a path list */
2158 lib
= strtok (gdbtk_lib_tmp
, GDBTK_PATH_SEP
);
2161 if (Tcl_VarEval (interp
, "lappend auto_path ", lib
, NULL
) != TCL_OK
)
2163 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2168 gdbtk_file
= concat (lib
, "/main.tcl", (char *) NULL
);
2169 if (access (gdbtk_file
, R_OK
) == 0)
2172 Tcl_SetVar (interp
, "GDBTK_LIBRARY", lib
, 0);
2176 while ((lib
= strtok (NULL
, ":")) != NULL
);
2178 free (gdbtk_lib_tmp
);
2182 /* Try finding it with the auto path. */
2184 static const char script
[] ="\
2185 proc gdbtk_find_main {} {\n\
2186 global auto_path GDBTK_LIBRARY\n\
2187 foreach dir $auto_path {\n\
2188 set f [file join $dir main.tcl]\n\
2189 if {[file exists $f]} then {\n\
2190 set GDBTK_LIBRARY $dir\n\
2198 if (Tcl_GlobalEval (interp
, (char *) script
) != TCL_OK
)
2200 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2204 if (interp
->result
[0] != '\0')
2206 gdbtk_file
= xstrdup (interp
->result
);
2213 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2214 if (getenv("GDBTK_LIBRARY"))
2216 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
2217 fprintf_unfiltered (stderr
,
2218 "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
2222 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY
);
2223 fprintf_unfiltered (stderr
, "You might want to set GDBTK_LIBRARY\n");
2228 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
2229 prior to this point go to stdout/stderr. */
2231 fputs_unfiltered_hook
= gdbtk_fputs
;
2233 if (Tcl_EvalFile (interp
, gdbtk_file
) != TCL_OK
)
2237 /* Force errorInfo to be set up propertly. */
2238 Tcl_AddErrorInfo (interp
, "");
2240 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
2242 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2245 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
2247 fputs_unfiltered (msg
, gdb_stderr
);
2254 /* start-sanitize-ide */
2255 /* Don't do this until we have initialized. Otherwise, we may get a
2256 run command before we are ready for one. */
2257 if (ide_run_server_init (interp
, h
) != TCL_OK
)
2258 error ("ide_run_server_init failed: %s", interp
->result
);
2259 /* end-sanitize-ide */
2264 discard_cleanups (old_chain
);
2268 gdb_target_has_execution_command (clientData
, interp
, argc
, argv
)
2269 ClientData clientData
;
2276 if (target_has_execution
&& inferior_pid
!= 0)
2279 Tcl_SetIntObj (Tcl_GetObjResult (interp
), result
);
2283 /* gdb_load_info - returns information about the file about to be downloaded */
2286 gdb_load_info (clientData
, interp
, objc
, objv
)
2287 ClientData clientData
;
2290 Tcl_Obj
*CONST objv
[];
2293 struct cleanup
*old_cleanups
;
2299 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
2301 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
2302 if (loadfile_bfd
== NULL
)
2304 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Open failed", -1));
2307 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
2309 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
2311 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Bad Object File", -1));
2315 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
2317 if (s
->flags
& SEC_LOAD
)
2319 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
2322 ob
[0] = Tcl_NewStringObj((char *)bfd_get_section_name(loadfile_bfd
, s
), -1);
2323 ob
[1] = Tcl_NewLongObj ((long)size
);
2324 res
[i
++] = Tcl_NewListObj (2, ob
);
2329 Tcl_SetObjResult (interp
, Tcl_NewListObj (i
, res
));
2330 do_cleanups (old_cleanups
);
2336 gdbtk_load_hash (section
, num
)
2341 sprintf (buf
, "download_hash %s %ld", section
, num
);
2342 Tcl_Eval (interp
, buf
);
2343 return atoi (interp
->result
);
2346 /* gdb_get_vars_command -
2348 * Implements the "gdb_get_locals" and "gdb_get_args" tcl commands. This
2349 * function sets the Tcl interpreter's result to a list of variable names
2350 * depending on clientData. If clientData is one, the result is a list of
2351 * arguments; zero returns a list of locals -- all relative to the block
2352 * specified as an argument to the command. Valid commands include
2353 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
2357 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
2358 ClientData clientData
;
2361 Tcl_Obj
*CONST objv
[];
2364 struct symtabs_and_lines sals
;
2366 struct block
*block
;
2367 char **canonical
, *args
;
2368 int i
, nsyms
, arguments
;
2372 Tcl_AppendResult (interp
,
2373 "wrong # of args: should be \"",
2374 Tcl_GetStringFromObj (objv
[0], NULL
),
2375 " function:line|function|line|*addr\"");
2379 arguments
= (int) clientData
;
2380 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2381 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2382 if (sals
.nelts
== 0)
2384 Tcl_AppendResult (interp
,
2385 "error decoding line", NULL
);
2389 /* Initialize a list that will hold the results */
2390 result
= Tcl_NewListObj (0, NULL
);
2392 /* Resolve all line numbers to PC's */
2393 for (i
= 0; i
< sals
.nelts
; i
++)
2394 resolve_sal_pc (&sals
.sals
[i
]);
2396 block
= block_for_pc (sals
.sals
[0].pc
);
2399 nsyms
= BLOCK_NSYMS (block
);
2400 for (i
= 0; i
< nsyms
; i
++)
2402 sym
= BLOCK_SYM (block
, i
);
2403 switch (SYMBOL_CLASS (sym
)) {
2405 case LOC_UNDEF
: /* catches errors */
2406 case LOC_CONST
: /* constant */
2407 case LOC_STATIC
: /* static */
2408 case LOC_REGISTER
: /* register */
2409 case LOC_TYPEDEF
: /* local typedef */
2410 case LOC_LABEL
: /* local label */
2411 case LOC_BLOCK
: /* local function */
2412 case LOC_CONST_BYTES
: /* loc. byte seq. */
2413 case LOC_UNRESOLVED
: /* unresolved static */
2414 case LOC_OPTIMIZED_OUT
: /* optimized out */
2416 case LOC_ARG
: /* argument */
2417 case LOC_REF_ARG
: /* reference arg */
2418 case LOC_REGPARM
: /* register arg */
2419 case LOC_REGPARM_ADDR
: /* indirect register arg */
2420 case LOC_LOCAL_ARG
: /* stack arg */
2421 case LOC_BASEREG_ARG
: /* basereg arg */
2423 Tcl_ListObjAppendElement (interp
, result
,
2424 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2426 case LOC_LOCAL
: /* stack local */
2427 case LOC_BASEREG
: /* basereg local */
2429 Tcl_ListObjAppendElement (interp
, result
,
2430 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2434 if (BLOCK_FUNCTION (block
))
2437 block
= BLOCK_SUPERBLOCK (block
);
2440 Tcl_SetObjResult (interp
, result
);
2445 gdb_get_line_command (clientData
, interp
, objc
, objv
)
2446 ClientData clientData
;
2449 Tcl_Obj
*CONST objv
[];
2452 struct symtabs_and_lines sals
;
2453 char *args
, **canonical
;
2457 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2458 Tcl_GetStringFromObj (objv
[0], NULL
),
2463 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2464 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2465 if (sals
.nelts
== 1)
2467 Tcl_SetObjResult (interp
, Tcl_NewIntObj (sals
.sals
[0].line
));
2471 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2476 gdb_get_file_command (clientData
, interp
, objc
, objv
)
2477 ClientData clientData
;
2480 Tcl_Obj
*CONST objv
[];
2483 struct symtabs_and_lines sals
;
2484 char *args
, **canonical
;
2488 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2489 Tcl_GetStringFromObj (objv
[0], NULL
),
2494 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2495 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2496 if (sals
.nelts
== 1)
2498 Tcl_SetResult (interp
, sals
.sals
[0].symtab
->filename
, TCL_VOLATILE
);
2502 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2507 gdb_get_function_command (clientData
, interp
, objc
, objv
)
2508 ClientData clientData
;
2511 Tcl_Obj
*CONST objv
[];
2515 struct symtabs_and_lines sals
;
2516 char *args
, **canonical
;
2520 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2521 Tcl_GetStringFromObj (objv
[0], NULL
),
2526 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2527 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2528 if (sals
.nelts
== 1)
2530 resolve_sal_pc (&sals
.sals
[0]);
2531 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
2532 if (function
!= NULL
)
2534 Tcl_SetResult (interp
, function
, TCL_VOLATILE
);
2539 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2544 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
2545 ClientData clientData
;
2548 Tcl_Obj
*CONST objv
[];
2550 struct symtab_and_line sal
;
2552 struct tracepoint
*tp
;
2553 struct action_line
*al
;
2554 Tcl_Obj
*list
, *action_list
;
2555 char *filename
, *funcname
;
2559 error ("wrong # args");
2561 Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
);
2563 ALL_TRACEPOINTS (tp
)
2564 if (tp
->number
== tpnum
)
2568 error ("Tracepoint #%d does not exist", tpnum
);
2570 list
= Tcl_NewListObj (0, NULL
);
2571 sal
= find_pc_line (tp
->address
, 0);
2572 filename
= symtab_to_filename (sal
.symtab
);
2573 if (filename
== NULL
)
2575 Tcl_ListObjAppendElement (interp
, list
,
2576 Tcl_NewStringObj (filename
, -1));
2577 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
2578 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (funcname
, -1));
2579 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (sal
.line
));
2580 sprintf (tmp
, "0x%08x", tp
->address
);
2581 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (tmp
, -1));
2582 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->enabled
));
2583 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->pass_count
));
2584 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->step_count
));
2585 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->thread
));
2586 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->hit_count
));
2588 /* Append a list of actions */
2589 action_list
= Tcl_NewListObj (0, NULL
);
2590 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
2592 Tcl_ListObjAppendElement (interp
, action_list
,
2593 Tcl_NewStringObj (al
->action
, -1));
2595 Tcl_ListObjAppendElement (interp
, list
, action_list
);
2597 Tcl_SetObjResult (interp
, list
);
2602 gdbtk_create_tracepoint (tp
)
2603 struct tracepoint
*tp
;
2605 tracepoint_notify (tp
, "create");
2609 gdbtk_delete_tracepoint (tp
)
2610 struct tracepoint
*tp
;
2612 tracepoint_notify (tp
, "delete");
2616 gdbtk_modify_tracepoint (tp
)
2617 struct tracepoint
*tp
;
2619 tracepoint_notify (tp
, "modify");
2623 tracepoint_notify(tp
, action
)
2624 struct tracepoint
*tp
;
2629 struct symtab_and_line sal
;
2632 /* We ensure that ACTION contains no special Tcl characters, so we
2634 sal
= find_pc_line (tp
->address
, 0);
2636 filename
= symtab_to_filename (sal
.symtab
);
2637 if (filename
== NULL
)
2639 sprintf (buf
, "gdbtk_tcl_tracepoint %s %d 0x%lx %d {%s}", action
, tp
->number
,
2640 (long)tp
->address
, sal
.line
, filename
);
2642 v
= Tcl_Eval (interp
, buf
);
2646 gdbtk_fputs (interp
->result
, gdb_stdout
);
2647 gdbtk_fputs ("\n", gdb_stdout
);
2651 /* returns -1 if not found, tracepoint # if found */
2653 tracepoint_exists (char * args
)
2655 struct tracepoint
*tp
;
2657 struct symtabs_and_lines sals
;
2661 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2662 if (sals
.nelts
== 1)
2664 resolve_sal_pc (&sals
.sals
[0]);
2665 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
2666 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
2669 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
2670 strcat (file
, sals
.sals
[0].symtab
->filename
);
2672 ALL_TRACEPOINTS (tp
)
2674 if (tp
->address
== sals
.sals
[0].pc
)
2675 result
= tp
->number
;
2676 else if (tp
->source_file
!= NULL
2677 && strcmp (tp
->source_file
, file
) == 0
2678 && sals
.sals
[0].line
== tp
->line_number
)
2680 result
= tp
->number
;
2690 gdb_actions_command (clientData
, interp
, objc
, objv
)
2691 ClientData clientData
;
2694 Tcl_Obj
*CONST objv
[];
2696 struct tracepoint
*tp
;
2698 int nactions
, i
, len
;
2699 char *number
, *args
, *action
;
2701 struct action_line
*next
= NULL
, *temp
;
2705 Tcl_AppendResult (interp
, "wrong # args: should be: \"",
2706 Tcl_GetStringFromObj (objv
[0], NULL
),
2707 " number actions\"");
2711 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
2712 tp
= get_tracepoint_by_number (&args
);
2715 Tcl_AppendResult (interp
, "Tracepoint \"", number
, "\" does not exist");
2719 /* Free any existing actions */
2720 if (tp
->actions
!= NULL
)
2725 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
2726 for (i
= 0; i
< nactions
; i
++)
2728 temp
= xmalloc (sizeof (struct action_line
));
2730 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
2731 temp
->action
= savestring (action
, len
);
2732 if (sscanf (temp
->action
, "while-stepping %d", &step_count
) !=0)
2733 tp
->step_count
= step_count
;
2750 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
2751 ClientData clientData
;
2754 Tcl_Obj
*CONST objv
[];
2760 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2761 Tcl_GetStringFromObj (objv
[0], NULL
),
2762 " function:line|function|line|*addr\"");
2766 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2768 Tcl_SetObjResult (interp
, Tcl_NewIntObj (tracepoint_exists (args
)));
2772 /* Return the prompt to the interpreter */
2774 gdb_prompt_command (clientData
, interp
, objc
, objv
)
2775 ClientData clientData
;
2778 Tcl_Obj
*CONST objv
[];
2780 Tcl_SetResult (interp
, get_prompt (), TCL_VOLATILE
);
2784 /* return a list of all tracepoint numbers in interpreter */
2786 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
2787 ClientData clientData
;
2790 Tcl_Obj
*CONST objv
[];
2793 struct tracepoint
*tp
;
2795 list
= Tcl_NewListObj (0, NULL
);
2797 ALL_TRACEPOINTS (tp
)
2798 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->number
));
2800 Tcl_SetObjResult (interp
, list
);
2804 /* This is stolen from source.c */
2805 #ifdef CRLF_SOURCE_FILES
2807 /* Define CRLF_SOURCE_FILES in an xm-*.h file if source files on the
2808 host use \r\n rather than just \n. Defining CRLF_SOURCE_FILES is
2809 much faster than defining LSEEK_NOT_LINEAR. */
2815 #define OPEN_MODE (O_RDONLY | O_BINARY)
2817 #else /* ! defined (CRLF_SOURCE_FILES) */
2819 #define OPEN_MODE O_RDONLY
2821 #endif /* ! defined (CRLF_SOURCE_FILES) */
2823 /* Find the pathname to a file, searching the source_dir */
2824 /* we may actually need to use openp to find the the full pathname
2825 so we don't have any "../" et al in it. */
2827 gdb_find_file_command (clientData
, interp
, objc
, objv
)
2828 ClientData clientData
;
2831 Tcl_Obj
*CONST objv
[];
2833 char *file
, *filename
;
2837 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2838 Tcl_GetStringFromObj (objv
[0], NULL
),
2843 file
= Tcl_GetStringFromObj (objv
[1], NULL
);
2844 filename
= find_file_in_dir (file
);
2846 if (filename
== NULL
)
2847 Tcl_SetResult (interp
, "", TCL_STATIC
);
2849 Tcl_SetObjResult (interp
, Tcl_NewStringObj (filename
, -1));
2855 find_file_in_dir (file
)
2858 struct symtab
*st
= NULL
;
2862 /* try something simple first */
2863 if (access (file
, R_OK
) == 0)
2866 /* We really need a symtab for this to work... */
2867 st
= lookup_symtab (file
);
2870 file
= symtab_to_filename (st
);
2879 /* This hook is called whenever we are ready to load a symbol file so that
2880 the UI can notify the user... */
2882 gdbtk_pre_add_symbol (name
)
2887 sprintf (command
, "gdbtk_tcl_pre_add_symbol %s", name
);
2888 Tcl_Eval (interp
, command
);
2891 /* This hook is called whenever we finish loading a symbol file. */
2893 gdbtk_post_add_symbol ()
2895 Tcl_Eval (interp
, "gdbtk_tcl_post_add_symbol");
2899 /* TclDebug (const char *fmt, ...) works just like printf() but */
2900 /* sends the output to the GDB TK debug window. */
2901 /* Not for normal use; just a convenient tool for debugging */
2903 #ifdef ANSI_PROTOTYPES
2904 TclDebug (const char *fmt
, ...)
2913 #ifdef ANSI_PROTOTYPES
2914 va_start (args
, fmt
);
2918 fmt
= va_arg (args
, char *);
2921 strcpy (buf
, "debug \"");
2922 vsprintf (&buf
[7], fmt
, args
);
2925 Tcl_Eval (interp
, buf
);
2929 gdbtk_print_frame_info (s
, line
, stopline
, noerror
)
2935 current_source_symtab
= s
;
2936 current_source_line
= line
;
2939 /* Come here during initialize_all_files () */
2942 _initialize_gdbtk ()
2946 /* Tell the rest of the world that Gdbtk is now set up. */
2948 init_ui_hook
= gdbtk_init
;