1 /* Tcl/Tk interface routines.
2 Copyright 1994, 1995, 1996, 1997 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. */
40 #ifdef ANSI_PROTOTYPES
50 #include <sys/ioctl.h>
51 #include "gdb_string.h"
58 #include <sys/stropts.h>
63 #define GDBTK_PATH_SEP ";"
65 #define GDBTK_PATH_SEP ":"
68 /* Some versions (1.3.79, 1.3.81) of Linux don't support SIOCSPGRP the way
69 gdbtk wants to use it... */
74 static void null_routine
PARAMS ((int));
75 static void gdbtk_flush
PARAMS ((FILE *));
76 static void gdbtk_fputs
PARAMS ((const char *, FILE *));
77 static int gdbtk_query
PARAMS ((const char *, va_list));
78 static char *gdbtk_readline
PARAMS ((char *));
79 static void gdbtk_init
PARAMS ((char *));
80 static void tk_command_loop
PARAMS ((void));
81 static void gdbtk_call_command
PARAMS ((struct cmd_list_element
*, char *, int));
82 static int gdbtk_wait
PARAMS ((int, struct target_waitstatus
*));
83 static void x_event
PARAMS ((int));
84 static void gdbtk_interactive
PARAMS ((void));
85 static void cleanup_init
PARAMS ((int));
86 static void tk_command
PARAMS ((char *, int));
87 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
88 static int compare_lines
PARAMS ((const PTR
, const PTR
));
89 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
90 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
91 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
92 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
93 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
94 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
95 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
96 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
97 static void gdbtk_readline_end
PARAMS ((void));
98 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
99 static void register_changed_p
PARAMS ((int, void *));
100 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
101 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
102 static void breakpoint_notify
PARAMS ((struct breakpoint
*, const char *));
103 static void gdbtk_create_breakpoint
PARAMS ((struct breakpoint
*));
104 static void gdbtk_delete_breakpoint
PARAMS ((struct breakpoint
*));
105 static void gdbtk_modify_breakpoint
PARAMS ((struct breakpoint
*));
106 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
107 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
108 static int gdb_sourcelines
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
109 static int map_arg_registers
PARAMS ((int, char *[], void (*) (int, void *), void *));
110 static void get_register_name
PARAMS ((int, void *));
111 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
112 static void get_register
PARAMS ((int, void *));
114 /* Handle for TCL interpreter */
116 static Tcl_Interp
*interp
= NULL
;
118 static int x_fd
; /* X network socket */
120 /* This variable is true when the inferior is running. Although it's
121 possible to disable most input from widgets and thus prevent
122 attempts to do anything while the inferior is running, any commands
123 that get through - even a simple memory read - are Very Bad, and
124 may cause GDB to crash or behave strangely. So, this variable
125 provides an extra layer of defense. */
127 static int running_now
;
129 /* This variable determines where memory used for disassembly is read from.
130 If > 0, then disassembly comes from the exec file rather than the
131 target (which might be at the other end of a slow serial link). If
132 == 0 then disassembly comes from target. If < 0 disassembly is
133 automatically switched to the target if it's an inferior process,
134 otherwise the exec file is used. */
136 static int disassemble_from_exec
= -1;
140 /* Supply malloc calls for tcl/tk. We do not want to do this on
141 Windows, because Tcl_Alloc is probably in a DLL which will not call
142 the mmalloc routines. */
148 return xmalloc (size
);
152 Tcl_Realloc (ptr
, size
)
156 return xrealloc (ptr
, size
);
174 /* The following routines deal with stdout/stderr data, which is created by
175 {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the
176 lowest level of these routines and capture all output from the rest of GDB.
177 Normally they present their data to tcl via callbacks to the following tcl
178 routines: gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush. These
179 in turn call tk routines to update the display.
181 Under some circumstances, you may want to collect the output so that it can
182 be returned as the value of a tcl procedure. This can be done by
183 surrounding the output routines with calls to start_saving_output and
184 finish_saving_output. The saved data can then be retrieved with
185 get_saved_output (but this must be done before the call to
186 finish_saving_output). */
188 /* Dynamic string header for stdout. */
190 static Tcl_DString
*result_ptr
;
197 /* Force immediate screen update */
199 Tcl_VarEval (interp
, "gdbtk_tcl_flush", NULL
);
204 gdbtk_fputs (ptr
, stream
)
209 Tcl_DStringAppend (result_ptr
, (char *)ptr
, -1);
214 Tcl_DStringInit (&str
);
216 Tcl_DStringAppend (&str
, "gdbtk_tcl_fputs", -1);
217 Tcl_DStringAppendElement (&str
, (char *)ptr
);
219 Tcl_Eval (interp
, Tcl_DStringValue (&str
));
220 Tcl_DStringFree (&str
);
225 gdbtk_query (query
, args
)
229 char buf
[200], *merge
[2];
233 vsprintf (buf
, query
, args
);
234 merge
[0] = "gdbtk_tcl_query";
236 command
= Tcl_Merge (2, merge
);
237 Tcl_Eval (interp
, command
);
240 val
= atol (interp
->result
);
246 #ifdef ANSI_PROTOTYPES
247 gdbtk_readline_begin (char *format
, ...)
249 gdbtk_readline_begin (va_alist
)
254 char buf
[200], *merge
[2];
257 #ifdef ANSI_PROTOTYPES
258 va_start (args
, format
);
262 format
= va_arg (args
, char *);
265 vsprintf (buf
, format
, args
);
266 merge
[0] = "gdbtk_tcl_readline_begin";
268 command
= Tcl_Merge (2, merge
);
269 Tcl_Eval (interp
, command
);
274 gdbtk_readline (prompt
)
281 merge
[0] = "gdbtk_tcl_readline";
283 command
= Tcl_Merge (2, merge
);
284 result
= Tcl_Eval (interp
, command
);
286 if (result
== TCL_OK
)
288 return (strdup (interp
-> result
));
292 gdbtk_fputs (interp
-> result
, gdb_stdout
);
293 gdbtk_fputs ("\n", gdb_stdout
);
299 gdbtk_readline_end ()
301 Tcl_Eval (interp
, "gdbtk_tcl_readline_end");
306 #ifdef ANSI_PROTOTYPES
307 dsprintf_append_element (Tcl_DString
*dsp
, char *format
, ...)
309 dsprintf_append_element (va_alist
)
316 #ifdef ANSI_PROTOTYPES
317 va_start (args
, format
);
323 dsp
= va_arg (args
, Tcl_DString
*);
324 format
= va_arg (args
, char *);
327 vsprintf (buf
, format
, args
);
329 Tcl_DStringAppendElement (dsp
, buf
);
333 gdb_path_conv (clientData
, interp
, argc
, argv
)
334 ClientData clientData
;
340 char pathname
[256], *ptr
;
342 error ("wrong # args");
343 cygwin32_conv_to_full_win32_path (argv
[1], pathname
);
344 for (ptr
= pathname
; *ptr
; ptr
++)
350 char *pathname
= argv
[1];
352 Tcl_DStringAppend (result_ptr
, pathname
, strlen(pathname
));
357 gdb_get_breakpoint_list (clientData
, interp
, argc
, argv
)
358 ClientData clientData
;
363 struct breakpoint
*b
;
364 extern struct breakpoint
*breakpoint_chain
;
367 error ("wrong # args");
369 for (b
= breakpoint_chain
; b
; b
= b
->next
)
370 if (b
->type
== bp_breakpoint
)
371 dsprintf_append_element (result_ptr
, "%d", b
->number
);
377 gdb_get_breakpoint_info (clientData
, interp
, argc
, argv
)
378 ClientData clientData
;
383 struct symtab_and_line sal
;
384 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
385 "finish", "watchpoint", "hardware watchpoint",
386 "read watchpoint", "access watchpoint",
387 "longjmp", "longjmp resume", "step resume",
388 "through sigtramp", "watchpoint scope",
390 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
391 struct command_line
*cmd
;
393 struct breakpoint
*b
;
394 extern struct breakpoint
*breakpoint_chain
;
397 error ("wrong # args");
399 bpnum
= atoi (argv
[1]);
401 for (b
= breakpoint_chain
; b
; b
= b
->next
)
402 if (b
->number
== bpnum
)
405 if (!b
|| b
->type
!= bp_breakpoint
)
406 error ("Breakpoint #%d does not exist", bpnum
);
408 sal
= find_pc_line (b
->address
, 0);
410 Tcl_DStringAppendElement (result_ptr
, symtab_to_filename (sal
.symtab
));
411 dsprintf_append_element (result_ptr
, "%d", sal
.line
);
412 dsprintf_append_element (result_ptr
, "0x%lx", b
->address
);
413 Tcl_DStringAppendElement (result_ptr
, bptypes
[b
->type
]);
414 Tcl_DStringAppendElement (result_ptr
, b
->enable
== enabled
? "1" : "0");
415 Tcl_DStringAppendElement (result_ptr
, bpdisp
[b
->disposition
]);
416 dsprintf_append_element (result_ptr
, "%d", b
->silent
);
417 dsprintf_append_element (result_ptr
, "%d", b
->ignore_count
);
419 Tcl_DStringStartSublist (result_ptr
);
420 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
421 Tcl_DStringAppendElement (result_ptr
, cmd
->line
);
422 Tcl_DStringEndSublist (result_ptr
);
424 Tcl_DStringAppendElement (result_ptr
, b
->cond_string
);
426 dsprintf_append_element (result_ptr
, "%d", b
->thread
);
427 dsprintf_append_element (result_ptr
, "%d", b
->hit_count
);
433 breakpoint_notify(b
, action
)
434 struct breakpoint
*b
;
439 struct symtab_and_line sal
;
441 if (b
->type
!= bp_breakpoint
)
444 /* We ensure that ACTION contains no special Tcl characters, so we
446 sal
= find_pc_line (b
->address
, 0);
447 sprintf (buf
, "gdbtk_tcl_breakpoint %s %d 0x%lx %d {%s}", action
, b
->number
,
448 (long)b
->address
, sal
.line
, symtab_to_filename (sal
.symtab
));
450 v
= Tcl_Eval (interp
, buf
);
454 gdbtk_fputs (interp
->result
, gdb_stdout
);
455 gdbtk_fputs ("\n", gdb_stdout
);
460 gdbtk_create_breakpoint(b
)
461 struct breakpoint
*b
;
463 breakpoint_notify (b
, "create");
467 gdbtk_delete_breakpoint(b
)
468 struct breakpoint
*b
;
470 breakpoint_notify (b
, "delete");
474 gdbtk_modify_breakpoint(b
)
475 struct breakpoint
*b
;
477 breakpoint_notify (b
, "modify");
480 /* This implements the TCL command `gdb_loc', which returns a list consisting
481 of the source and line number associated with the current pc. */
484 gdb_loc (clientData
, interp
, argc
, argv
)
485 ClientData clientData
;
491 struct symtab_and_line sal
;
497 pc
= selected_frame
? selected_frame
->pc
: stop_pc
;
498 sal
= find_pc_line (pc
, 0);
502 struct symtabs_and_lines sals
;
505 sals
= decode_line_spec (argv
[1], 1);
512 error ("Ambiguous line spec");
517 error ("wrong # args");
520 Tcl_DStringAppendElement (result_ptr
, sal
.symtab
->filename
);
522 Tcl_DStringAppendElement (result_ptr
, "");
524 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
525 Tcl_DStringAppendElement (result_ptr
, funcname
);
527 filename
= symtab_to_filename (sal
.symtab
);
528 Tcl_DStringAppendElement (result_ptr
, filename
);
530 dsprintf_append_element (result_ptr
, "%d", sal
.line
); /* line number */
532 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
534 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
539 /* This implements the TCL command `gdb_eval'. */
542 gdb_eval (clientData
, interp
, argc
, argv
)
543 ClientData clientData
;
548 struct expression
*expr
;
549 struct cleanup
*old_chain
;
553 error ("wrong # args");
555 expr
= parse_expression (argv
[1]);
557 old_chain
= make_cleanup (free_current_contents
, &expr
);
559 val
= evaluate_expression (expr
);
561 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
562 gdb_stdout
, 0, 0, 0, 0);
564 do_cleanups (old_chain
);
569 /* This implements the TCL command `gdb_sourcelines', which returns a list of
570 all of the lines containing executable code for the specified source file
571 (ie: lines where you can put breakpoints). */
574 gdb_sourcelines (clientData
, interp
, argc
, argv
)
575 ClientData clientData
;
580 struct symtab
*symtab
;
581 struct linetable_entry
*le
;
585 error ("wrong # args");
587 symtab
= lookup_symtab (argv
[1]);
590 error ("No such file");
592 /* If there's no linetable, or no entries, then we are done. */
594 if (!symtab
->linetable
595 || symtab
->linetable
->nitems
== 0)
597 Tcl_DStringAppendElement (result_ptr
, "");
601 le
= symtab
->linetable
->item
;
602 nlines
= symtab
->linetable
->nitems
;
604 for (;nlines
> 0; nlines
--, le
++)
606 /* If the pc of this line is the same as the pc of the next line, then
609 && le
->pc
== (le
+ 1)->pc
)
612 dsprintf_append_element (result_ptr
, "%d", le
->line
);
619 map_arg_registers (argc
, argv
, func
, argp
)
622 void (*func
) PARAMS ((int regnum
, void *argp
));
627 /* Note that the test for a valid register must include checking the
628 reg_names array because NUM_REGS may be allocated for the union of the
629 register sets within a family of related processors. In this case, the
630 trailing entries of reg_names will change depending upon the particular
631 processor being debugged. */
633 if (argc
== 0) /* No args, just do all the regs */
637 && reg_names
[regnum
] != NULL
638 && *reg_names
[regnum
] != '\000';
645 /* Else, list of register #s, just do listed regs */
646 for (; argc
> 0; argc
--, argv
++)
648 regnum
= atoi (*argv
);
652 && reg_names
[regnum
] != NULL
653 && *reg_names
[regnum
] != '\000')
656 error ("bad register number");
663 get_register_name (regnum
, argp
)
665 void *argp
; /* Ignored */
667 Tcl_DStringAppendElement (result_ptr
, reg_names
[regnum
]);
670 /* This implements the TCL command `gdb_regnames', which returns a list of
671 all of the register names. */
674 gdb_regnames (clientData
, interp
, argc
, argv
)
675 ClientData clientData
;
683 return map_arg_registers (argc
, argv
, get_register_name
, NULL
);
686 #ifndef REGISTER_CONVERTIBLE
687 #define REGISTER_CONVERTIBLE(x) (0 != 0)
690 #ifndef REGISTER_CONVERT_TO_VIRTUAL
691 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
694 #ifndef INVALID_FLOAT
695 #define INVALID_FLOAT(x, y) (0 != 0)
699 get_register (regnum
, fp
)
703 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
704 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
705 int format
= (int)fp
;
707 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
709 Tcl_DStringAppendElement (result_ptr
, "Optimized out");
713 /* Convert raw data to virtual format if necessary. */
715 if (REGISTER_CONVERTIBLE (regnum
))
717 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
718 raw_buffer
, virtual_buffer
);
721 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
726 printf_filtered ("0x");
727 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
729 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
730 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
731 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
735 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
736 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
738 Tcl_DStringAppend (result_ptr
, " ", -1);
742 gdb_fetch_registers (clientData
, interp
, argc
, argv
)
743 ClientData clientData
;
751 error ("wrong # args");
759 return map_arg_registers (argc
, argv
, get_register
, (void *) format
);
762 /* This contains the previous values of the registers, since the last call to
763 gdb_changed_register_list. */
765 static char old_regs
[REGISTER_BYTES
];
768 register_changed_p (regnum
, argp
)
770 void *argp
; /* Ignored */
772 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
774 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
777 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
778 REGISTER_RAW_SIZE (regnum
)) == 0)
781 /* Found a changed register. Save new value and return its number. */
783 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
784 REGISTER_RAW_SIZE (regnum
));
786 dsprintf_append_element (result_ptr
, "%d", regnum
);
790 gdb_changed_register_list (clientData
, interp
, argc
, argv
)
791 ClientData clientData
;
799 return map_arg_registers (argc
, argv
, register_changed_p
, NULL
);
802 /* This implements the TCL command `gdb_cmd', which sends its argument into
803 the GDB command scanner. */
806 gdb_cmd (clientData
, interp
, argc
, argv
)
807 ClientData clientData
;
813 error ("wrong # args");
818 execute_command (argv
[1], 1);
820 bpstat_do_actions (&stop_bpstat
);
825 /* Client of call_wrapper - this routine performs the actual call to
826 the client function. */
828 struct wrapped_call_args
839 struct wrapped_call_args
*args
;
841 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->argc
, args
->argv
);
845 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
846 handles cleanups, and calls to return_to_top_level (usually via error).
847 This is necessary in order to prevent a longjmp out of the bowels of Tk,
848 possibly leaving things in a bad state. Since this routine can be called
849 recursively, it needs to save and restore the contents of the jmp_buf as
853 call_wrapper (clientData
, interp
, argc
, argv
)
854 ClientData clientData
;
859 struct wrapped_call_args wrapped_args
;
860 Tcl_DString result
, *old_result_ptr
;
862 Tcl_DStringInit (&result
);
863 old_result_ptr
= result_ptr
;
864 result_ptr
= &result
;
866 wrapped_args
.func
= (Tcl_CmdProc
*)clientData
;
867 wrapped_args
.interp
= interp
;
868 wrapped_args
.argc
= argc
;
869 wrapped_args
.argv
= argv
;
870 wrapped_args
.val
= 0;
872 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
874 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
876 gdb_flush (gdb_stderr
); /* Flush error output */
878 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
880 /* In case of an error, we may need to force the GUI into idle
881 mode because gdbtk_call_command may have bombed out while in
882 the command routine. */
885 Tcl_Eval (interp
, "gdbtk_tcl_idle");
888 Tcl_DStringResult (interp
, &result
);
889 result_ptr
= old_result_ptr
;
891 return wrapped_args
.val
;
895 gdb_listfiles (clientData
, interp
, argc
, argv
)
896 ClientData clientData
;
901 struct objfile
*objfile
;
902 struct partial_symtab
*psymtab
;
903 struct symtab
*symtab
;
905 ALL_PSYMTABS (objfile
, psymtab
)
906 Tcl_DStringAppendElement (result_ptr
, psymtab
->filename
);
908 ALL_SYMTABS (objfile
, symtab
)
909 Tcl_DStringAppendElement (result_ptr
, symtab
->filename
);
915 gdb_listfuncs (clientData
, interp
, argc
, argv
)
916 ClientData clientData
;
921 struct symtab
*symtab
;
922 struct blockvector
*bv
;
928 error ("wrong # args");
930 symtab
= lookup_symtab (argv
[1]);
933 error ("No such file");
935 bv
= BLOCKVECTOR (symtab
);
936 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
938 b
= BLOCKVECTOR_BLOCK (bv
, i
);
939 /* Skip the sort if this block is always sorted. */
940 if (!BLOCK_SHOULD_SORT (b
))
942 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
944 sym
= BLOCK_SYM (b
, j
);
945 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
947 Tcl_DStringAppendElement (result_ptr
, SYMBOL_NAME(sym
));
955 gdb_stop (clientData
, interp
, argc
, argv
)
956 ClientData clientData
;
964 quit_flag
= 1; /* hope something sees this */
969 /* This implements the TCL command `gdb_disassemble'. */
972 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
976 disassemble_info
*info
;
978 extern struct target_ops exec_ops
;
982 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
993 /* We need a different sort of line table from the normal one cuz we can't
994 depend upon implicit line-end pc's for lines. This is because of the
995 reordering we are about to do. */
997 struct my_line_entry
{
1004 compare_lines (mle1p
, mle2p
)
1008 struct my_line_entry
*mle1
, *mle2
;
1011 mle1
= (struct my_line_entry
*) mle1p
;
1012 mle2
= (struct my_line_entry
*) mle2p
;
1014 val
= mle1
->line
- mle2
->line
;
1019 return mle1
->start_pc
- mle2
->start_pc
;
1023 gdb_disassemble (clientData
, interp
, argc
, argv
)
1024 ClientData clientData
;
1029 CORE_ADDR pc
, low
, high
;
1030 int mixed_source_and_assembly
;
1031 static disassemble_info di
;
1032 static int di_initialized
;
1034 if (! di_initialized
)
1036 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
1037 (fprintf_ftype
) fprintf_unfiltered
);
1038 di
.flavour
= bfd_target_unknown_flavour
;
1039 di
.memory_error_func
= dis_asm_memory_error
;
1040 di
.print_address_func
= dis_asm_print_address
;
1044 di
.mach
= tm_print_insn_info
.mach
;
1045 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
1046 di
.endian
= BFD_ENDIAN_BIG
;
1048 di
.endian
= BFD_ENDIAN_LITTLE
;
1050 if (argc
!= 3 && argc
!= 4)
1051 error ("wrong # args");
1053 if (strcmp (argv
[1], "source") == 0)
1054 mixed_source_and_assembly
= 1;
1055 else if (strcmp (argv
[1], "nosource") == 0)
1056 mixed_source_and_assembly
= 0;
1058 error ("First arg must be 'source' or 'nosource'");
1060 low
= parse_and_eval_address (argv
[2]);
1064 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
1065 error ("No function contains specified address");
1068 high
= parse_and_eval_address (argv
[3]);
1070 /* If disassemble_from_exec == -1, then we use the following heuristic to
1071 determine whether or not to do disassembly from target memory or from the
1074 If we're debugging a local process, read target memory, instead of the
1075 exec file. This makes disassembly of functions in shared libs work
1078 Else, we're debugging a remote process, and should disassemble from the
1079 exec file for speed. However, this is no good if the target modifies its
1080 code (for relocation, or whatever).
1083 if (disassemble_from_exec
== -1)
1084 if (strcmp (target_shortname
, "child") == 0
1085 || strcmp (target_shortname
, "procfs") == 0
1086 || strcmp (target_shortname
, "vxprocess") == 0)
1087 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
1089 disassemble_from_exec
= 1; /* It's remote, read the exec file */
1091 if (disassemble_from_exec
)
1092 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
1094 di
.read_memory_func
= dis_asm_read_memory
;
1096 /* If just doing straight assembly, all we need to do is disassemble
1097 everything between low and high. If doing mixed source/assembly, we've
1098 got a totally different path to follow. */
1100 if (mixed_source_and_assembly
)
1101 { /* Come here for mixed source/assembly */
1102 /* The idea here is to present a source-O-centric view of a function to
1103 the user. This means that things are presented in source order, with
1104 (possibly) out of order assembly immediately following. */
1105 struct symtab
*symtab
;
1106 struct linetable_entry
*le
;
1109 struct my_line_entry
*mle
;
1110 struct symtab_and_line sal
;
1115 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
1120 /* First, convert the linetable to a bunch of my_line_entry's. */
1122 le
= symtab
->linetable
->item
;
1123 nlines
= symtab
->linetable
->nitems
;
1128 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
1132 /* Copy linetable entries for this function into our data structure, creating
1133 end_pc's and setting out_of_order as appropriate. */
1135 /* First, skip all the preceding functions. */
1137 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
1139 /* Now, copy all entries before the end of this function. */
1142 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
1144 if (le
[i
].line
== le
[i
+ 1].line
1145 && le
[i
].pc
== le
[i
+ 1].pc
)
1146 continue; /* Ignore duplicates */
1148 mle
[newlines
].line
= le
[i
].line
;
1149 if (le
[i
].line
> le
[i
+ 1].line
)
1151 mle
[newlines
].start_pc
= le
[i
].pc
;
1152 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
1156 /* If we're on the last line, and it's part of the function, then we need to
1157 get the end pc in a special way. */
1162 mle
[newlines
].line
= le
[i
].line
;
1163 mle
[newlines
].start_pc
= le
[i
].pc
;
1164 sal
= find_pc_line (le
[i
].pc
, 0);
1165 mle
[newlines
].end_pc
= sal
.end
;
1169 /* Now, sort mle by line #s (and, then by addresses within lines). */
1172 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
1174 /* Now, for each line entry, emit the specified lines (unless they have been
1175 emitted before), followed by the assembly code for that line. */
1177 next_line
= 0; /* Force out first line */
1178 for (i
= 0; i
< newlines
; i
++)
1180 /* Print out everything from next_line to the current line. */
1182 if (mle
[i
].line
>= next_line
)
1185 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
1187 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
1189 next_line
= mle
[i
].line
+ 1;
1192 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
1195 fputs_unfiltered (" ", gdb_stdout
);
1196 print_address (pc
, gdb_stdout
);
1197 fputs_unfiltered (":\t ", gdb_stdout
);
1198 pc
+= (*tm_print_insn
) (pc
, &di
);
1199 fputs_unfiltered ("\n", gdb_stdout
);
1206 for (pc
= low
; pc
< high
; )
1209 fputs_unfiltered (" ", gdb_stdout
);
1210 print_address (pc
, gdb_stdout
);
1211 fputs_unfiltered (":\t ", gdb_stdout
);
1212 pc
+= (*tm_print_insn
) (pc
, &di
);
1213 fputs_unfiltered ("\n", gdb_stdout
);
1217 gdb_flush (gdb_stdout
);
1223 tk_command (cmd
, from_tty
)
1229 struct cleanup
*old_chain
;
1231 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1233 error_no_arg ("tcl command to interpret");
1235 retval
= Tcl_Eval (interp
, cmd
);
1237 result
= strdup (interp
->result
);
1239 old_chain
= make_cleanup (free
, result
);
1241 if (retval
!= TCL_OK
)
1244 printf_unfiltered ("%s\n", result
);
1246 do_cleanups (old_chain
);
1250 cleanup_init (ignored
)
1254 Tcl_DeleteInterp (interp
);
1258 /* Come here during long calculations to check for GUI events. Usually invoked
1259 via the QUIT macro. */
1262 gdbtk_interactive ()
1264 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1267 /* Come here when there is activity on the X file descriptor. */
1273 /* Process pending events */
1275 while (Tcl_DoOneEvent (TCL_DONT_WAIT
|TCL_ALL_EVENTS
) != 0);
1279 gdbtk_wait (pid
, ourstatus
)
1281 struct target_waitstatus
*ourstatus
;
1283 struct sigaction action
;
1284 static sigset_t nullsigmask
= {0};
1287 /* Needed for SunOS 4.1.x */
1288 #define SA_RESTART 0
1291 action
.sa_handler
= x_event
;
1292 action
.sa_mask
= nullsigmask
;
1293 action
.sa_flags
= SA_RESTART
;
1295 sigaction(SIGIO
, &action
, NULL
);
1298 pid
= target_wait (pid
, ourstatus
);
1300 action
.sa_handler
= SIG_IGN
;
1302 sigaction(SIGIO
, &action
, NULL
);
1308 /* This is called from execute_command, and provides a wrapper around
1309 various command routines in a place where both protocol messages and
1310 user input both flow through. Mostly this is used for indicating whether
1311 the target process is running or not.
1315 gdbtk_call_command (cmdblk
, arg
, from_tty
)
1316 struct cmd_list_element
*cmdblk
;
1321 if (cmdblk
->class == class_run
)
1324 Tcl_Eval (interp
, "gdbtk_tcl_busy");
1325 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1327 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1330 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1333 /* This function is called instead of gdb's internal command loop. This is the
1334 last chance to do anything before entering the main Tk event loop. */
1339 extern GDB_FILE
*instream
;
1341 /* We no longer want to use stdin as the command input stream */
1343 Tcl_Eval (interp
, "gdbtk_tcl_preloop");
1347 /* gdbtk_init installs this function as a final cleanup. */
1350 gdbtk_cleanup (dummy
)
1356 /* Initialize gdbtk. */
1359 gdbtk_init ( argv0
)
1362 struct cleanup
*old_chain
;
1363 char *lib
, *gdbtk_lib
, *gdbtk_lib_tmp
, *gdbtk_file
;
1365 struct sigaction action
;
1366 static sigset_t nullsigmask
= {0};
1368 struct ide_event_handle
*h
;
1373 /* If there is no DISPLAY environment variable, Tk_Init below will fail,
1374 causing gdb to abort. If instead we simply return here, gdb will
1375 gracefully degrade to using the command line interface. */
1378 if (getenv ("DISPLAY") == NULL
)
1382 old_chain
= make_cleanup (cleanup_init
, 0);
1384 /* First init tcl and tk. */
1385 Tcl_FindExecutable (argv0
);
1386 interp
= Tcl_CreateInterp ();
1389 error ("Tcl_CreateInterp failed");
1391 if (Tcl_Init(interp
) != TCL_OK
)
1392 error ("Tcl_Init failed: %s", interp
->result
);
1394 make_final_cleanup (gdbtk_cleanup
, NULL
);
1397 /* Initialize the Paths variable. */
1398 if (ide_initialize_paths (interp
, "gdbtcl") != TCL_OK
)
1399 error ("ide_initialize_paths failed: %s", interp
->result
);
1401 /* Find the directory where we expect to find idemanager. We ignore
1402 errors since it doesn't really matter if this fails. */
1403 libexecdir
= Tcl_GetVar2 (interp
, "Paths", "libexecdir", TCL_GLOBAL_ONLY
);
1407 h
= ide_event_init_from_environment (&errmsg
, libexecdir
);
1410 Tcl_AppendResult (interp
, "can't initialize event system: ", errmsg
,
1412 fprintf(stderr
, "WARNING: ide_event_init_client failed: %s\n", interp
->result
);
1414 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
1418 if (ide_create_tclevent_command (interp
, h
) != TCL_OK
)
1419 error ("ide_create_tclevent_command failed: %s", interp
->result
);
1420 if (ide_create_edit_command (interp
, h
) != TCL_OK
)
1421 error ("ide_create_edit_command failed: %s", interp
->result
);
1423 if (ide_create_property_command (interp
, h
) != TCL_OK
)
1424 error ("ide_create_property_command failed: %s", interp
->result
);
1426 if (ide_create_window_register_command (interp
, h
) != TCL_OK
)
1427 error ("ide_create_window_register_command failed: %s",
1430 if (ide_create_window_command (interp
, h
) != TCL_OK
)
1431 error ("ide_create_window_command failed: %s", interp
->result
);
1434 if (ide_initialize (interp, "gdb") != TCL_OK)
1435 error ("ide_initialize failed: %s", interp->result);
1438 Tcl_SetVar (interp
, "GDBTK_IDE", "1", 0);
1441 Tcl_SetVar (interp
, "GDBTK_IDE", "0", 0);
1444 /* We don't want to open the X connection until we've done all the
1445 IDE initialization. Otherwise, goofy looking unfinished windows
1446 pop up when ILU drops into the TCL event loop. */
1448 if (Tk_Init(interp
) != TCL_OK
)
1449 error ("Tk_Init failed: %s", interp
->result
);
1451 if (Itcl_Init(interp
) == TCL_ERROR
)
1452 error ("Itcl_Init failed: %s", interp
->result
);
1454 if (Tix_Init(interp
) != TCL_OK
)
1455 error ("Tix_Init failed: %s", interp
->result
);
1457 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
1458 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
1459 Tcl_CreateCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
1460 Tcl_CreateCommand (interp
, "gdb_sourcelines", call_wrapper
, gdb_sourcelines
,
1462 Tcl_CreateCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
,
1464 Tcl_CreateCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
1466 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
1467 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
1468 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
1469 gdb_fetch_registers
, NULL
);
1470 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
1471 gdb_changed_register_list
, NULL
);
1472 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
1473 gdb_disassemble
, NULL
);
1474 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
1475 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
1476 gdb_get_breakpoint_list
, NULL
);
1477 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
1478 gdb_get_breakpoint_info
, NULL
);
1480 command_loop_hook
= tk_command_loop
;
1481 print_frame_info_listing_hook
=
1482 (void (*) PARAMS ((struct symtab
*, int, int, int))) null_routine
;
1483 query_hook
= gdbtk_query
;
1484 flush_hook
= gdbtk_flush
;
1485 create_breakpoint_hook
= gdbtk_create_breakpoint
;
1486 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
1487 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
1488 interactive_hook
= gdbtk_interactive
;
1489 target_wait_hook
= gdbtk_wait
;
1490 call_command_hook
= gdbtk_call_command
;
1491 readline_begin_hook
= gdbtk_readline_begin
;
1492 readline_hook
= gdbtk_readline
;
1493 readline_end_hook
= gdbtk_readline_end
;
1495 /* Get the file descriptor for the X server */
1497 x_fd
= ConnectionNumber (Tk_Display (Tk_MainWindow (interp
)));
1499 /* Setup for I/O interrupts */
1501 action
.sa_mask
= nullsigmask
;
1502 action
.sa_flags
= 0;
1503 action
.sa_handler
= SIG_IGN
;
1505 sigaction(SIGIO
, &action
, NULL
);
1510 if (ioctl (x_fd
, FIOASYNC
, &i
))
1511 perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1515 if (ioctl (x_fd
, SIOCSPGRP
, &i
))
1516 perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1521 if (fcntl (x_fd
, F_SETOWN
, i
))
1522 perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
1523 #endif /* F_SETOWN */
1524 #endif /* !SIOCSPGRP */
1527 if (ioctl (x_fd
, I_SETSIG
, S_INPUT
|S_RDNORM
) < 0)
1528 perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1531 #endif /* ifndef FIOASYNC */
1533 add_com ("tk", class_obscure
, tk_command
,
1534 "Send a command directly into tk.");
1536 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
1539 /* find the gdb tcl library and source main.tcl */
1541 gdbtk_lib
= getenv ("GDBTK_LIBRARY");
1543 if (access ("gdbtcl/main.tcl", R_OK
) == 0)
1544 gdbtk_lib
= "gdbtcl";
1546 gdbtk_lib
= GDBTK_LIBRARY
;
1548 gdbtk_lib_tmp
= xstrdup (gdbtk_lib
);
1551 /* see if GDBTK_LIBRARY is a path list */
1552 lib
= strtok (gdbtk_lib_tmp
, GDBTK_PATH_SEP
);
1555 if (Tcl_VarEval (interp
, "lappend auto_path ", lib
, NULL
) != TCL_OK
)
1557 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
1562 gdbtk_file
= concat (lib
, "/main.tcl", (char *) NULL
);
1563 if (access (gdbtk_file
, R_OK
) == 0)
1566 Tcl_SetVar (interp
, "GDBTK_LIBRARY", lib
, 0);
1570 while ((lib
= strtok (NULL
, ":")) != NULL
);
1572 free (gdbtk_lib_tmp
);
1577 /* Try finding it with the auto path. */
1579 static const char script
[] ="\
1580 proc gdbtk_find_main {} {\n\
1581 global auto_path GDBTK_LIBRARY\n\
1582 foreach dir $auto_path {\n\
1583 set f [file join $dir main.tcl]\n\
1584 if {[file exists $f]} then {\n\
1585 set GDBTK_LIBRARY $dir\n\
1593 if (Tcl_GlobalEval (interp
, (char *) script
) != TCL_OK
)
1595 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
1599 if (interp
->result
[0] != '\0')
1601 gdbtk_file
= xstrdup (interp
->result
);
1609 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
1610 if (getenv("GDBTK_LIBRARY"))
1612 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
1613 fprintf_unfiltered (stderr
,
1614 "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
1618 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY
);
1619 fprintf_unfiltered (stderr
, "You might want to set GDBTK_LIBRARY\n");
1624 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
1625 prior to this point go to stdout/stderr. */
1627 fputs_unfiltered_hook
= gdbtk_fputs
;
1629 if (Tcl_EvalFile (interp
, gdbtk_file
) != TCL_OK
)
1631 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
1633 fprintf_unfiltered (stderr
, "%s:%d: %s\n", gdbtk_file
,
1634 interp
->errorLine
, interp
->result
);
1636 fputs_unfiltered ("Stack trace:\n", gdb_stderr
);
1637 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
1643 discard_cleanups (old_chain
);
1646 /* Come here during initialize_all_files () */
1649 _initialize_gdbtk ()
1653 /* Tell the rest of the world that Gdbtk is now set up. */
1655 init_ui_hook
= gdbtk_init
;