1 /* Tcl/Tk interface routines.
2 Copyright 1994, 1995, 1996 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. */
32 #ifdef ANSI_PROTOTYPES
42 #include <sys/ioctl.h>
43 #include "gdb_string.h"
49 #include <sys/stropts.h>
52 /* Some versions (1.3.79, 1.3.81) of Linux don't support SIOCSPGRP the way
53 gdbtk wants to use it... */
58 static void null_routine
PARAMS ((int));
59 static void gdbtk_flush
PARAMS ((FILE *));
60 static void gdbtk_fputs
PARAMS ((const char *, FILE *));
61 static int gdbtk_query
PARAMS ((const char *, va_list));
62 static char *gdbtk_readline
PARAMS ((char *));
63 static void gdbtk_init
PARAMS ((void));
64 static void tk_command_loop
PARAMS ((void));
65 static void gdbtk_call_command
PARAMS ((struct cmd_list_element
*, char *, int));
66 static int gdbtk_wait
PARAMS ((int, struct target_waitstatus
*));
67 static void x_event
PARAMS ((int));
68 static void gdbtk_interactive
PARAMS ((void));
69 static void cleanup_init
PARAMS ((int));
70 static void tk_command
PARAMS ((char *, int));
71 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
72 static int compare_lines
PARAMS ((const PTR
, const PTR
));
73 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
74 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
75 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
76 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
77 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
78 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
79 static void gdbtk_readline_end
PARAMS ((void));
80 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
81 static void register_changed_p
PARAMS ((int, void *));
82 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
83 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
84 static void breakpoint_notify
PARAMS ((struct breakpoint
*, const char *));
85 static void gdbtk_create_breakpoint
PARAMS ((struct breakpoint
*));
86 static void gdbtk_delete_breakpoint
PARAMS ((struct breakpoint
*));
87 static void gdbtk_modify_breakpoint
PARAMS ((struct breakpoint
*));
88 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
89 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
90 static int gdb_sourcelines
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
91 static int map_arg_registers
PARAMS ((int, char *[], void (*) (int, void *), void *));
92 static void get_register_name
PARAMS ((int, void *));
93 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
94 static void get_register
PARAMS ((int, void *));
96 /* Handle for TCL interpreter */
98 static Tcl_Interp
*interp
= NULL
;
100 static int x_fd
; /* X network socket */
102 /* This variable is true when the inferior is running. Although it's
103 possible to disable most input from widgets and thus prevent
104 attempts to do anything while the inferior is running, any commands
105 that get through - even a simple memory read - are Very Bad, and
106 may cause GDB to crash or behave strangely. So, this variable
107 provides an extra layer of defense. */
109 static int running_now
;
111 /* This variable determines where memory used for disassembly is read from.
112 If > 0, then disassembly comes from the exec file rather than the
113 target (which might be at the other end of a slow serial link). If
114 == 0 then disassembly comes from target. If < 0 disassembly is
115 automatically switched to the target if it's an inferior process,
116 otherwise the exec file is used. */
118 static int disassemble_from_exec
= -1;
120 /* Supply malloc calls for tcl/tk. */
126 return xmalloc (size
);
130 Tcl_Realloc (ptr
, size
)
134 return xrealloc (ptr
, size
);
150 /* The following routines deal with stdout/stderr data, which is created by
151 {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the
152 lowest level of these routines and capture all output from the rest of GDB.
153 Normally they present their data to tcl via callbacks to the following tcl
154 routines: gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush. These
155 in turn call tk routines to update the display.
157 Under some circumstances, you may want to collect the output so that it can
158 be returned as the value of a tcl procedure. This can be done by
159 surrounding the output routines with calls to start_saving_output and
160 finish_saving_output. The saved data can then be retrieved with
161 get_saved_output (but this must be done before the call to
162 finish_saving_output). */
164 /* Dynamic string header for stdout. */
166 static Tcl_DString
*result_ptr
;
173 /* Force immediate screen update */
175 Tcl_VarEval (interp
, "gdbtk_tcl_flush", NULL
);
180 gdbtk_fputs (ptr
, stream
)
186 Tcl_DStringAppend (result_ptr
, (char *)ptr
, -1);
191 Tcl_DStringInit (&str
);
193 Tcl_DStringAppend (&str
, "gdbtk_tcl_fputs", -1);
194 Tcl_DStringAppendElement (&str
, (char *)ptr
);
196 Tcl_Eval (interp
, Tcl_DStringValue (&str
));
197 Tcl_DStringFree (&str
);
202 gdbtk_query (query
, args
)
206 char buf
[200], *merge
[2];
210 vsprintf (buf
, query
, args
);
211 merge
[0] = "gdbtk_tcl_query";
213 command
= Tcl_Merge (2, merge
);
214 Tcl_Eval (interp
, command
);
217 val
= atol (interp
->result
);
223 #ifdef ANSI_PROTOTYPES
224 gdbtk_readline_begin (char *format
, ...)
226 gdbtk_readline_begin (va_alist
)
231 char buf
[200], *merge
[2];
234 #ifdef ANSI_PROTOTYPES
235 va_start (args
, format
);
239 format
= va_arg (args
, char *);
242 vsprintf (buf
, format
, args
);
243 merge
[0] = "gdbtk_tcl_readline_begin";
245 command
= Tcl_Merge (2, merge
);
246 Tcl_Eval (interp
, command
);
251 gdbtk_readline (prompt
)
258 merge
[0] = "gdbtk_tcl_readline";
260 command
= Tcl_Merge (2, merge
);
261 result
= Tcl_Eval (interp
, command
);
263 if (result
== TCL_OK
)
265 return (strdup (interp
-> result
));
269 gdbtk_fputs (interp
-> result
, gdb_stdout
);
270 gdbtk_fputs ("\n", gdb_stdout
);
276 gdbtk_readline_end ()
278 Tcl_Eval (interp
, "gdbtk_tcl_readline_end");
283 #ifdef ANSI_PROTOTYPES
284 dsprintf_append_element (Tcl_DString
*dsp
, char *format
, ...)
286 dsprintf_append_element (va_alist
)
293 #ifdef ANSI_PROTOTYPES
294 va_start (args
, format
);
300 dsp
= va_arg (args
, Tcl_DString
*);
301 format
= va_arg (args
, char *);
304 vsprintf (buf
, format
, args
);
306 Tcl_DStringAppendElement (dsp
, buf
);
310 gdb_get_breakpoint_list (clientData
, interp
, argc
, argv
)
311 ClientData clientData
;
316 struct breakpoint
*b
;
317 extern struct breakpoint
*breakpoint_chain
;
320 error ("wrong # args");
322 for (b
= breakpoint_chain
; b
; b
= b
->next
)
323 if (b
->type
== bp_breakpoint
)
324 dsprintf_append_element (result_ptr
, "%d", b
->number
);
330 gdb_get_breakpoint_info (clientData
, interp
, argc
, argv
)
331 ClientData clientData
;
336 struct symtab_and_line sal
;
337 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
338 "finish", "watchpoint", "hardware watchpoint",
339 "read watchpoint", "access watchpoint",
340 "longjmp", "longjmp resume", "step resume",
341 "through sigtramp", "watchpoint scope",
343 static char *bpdisp
[] = {"delete", "disable", "donttouch"};
344 struct command_line
*cmd
;
346 struct breakpoint
*b
;
347 extern struct breakpoint
*breakpoint_chain
;
350 error ("wrong # args");
352 bpnum
= atoi (argv
[1]);
354 for (b
= breakpoint_chain
; b
; b
= b
->next
)
355 if (b
->number
== bpnum
)
358 if (!b
|| b
->type
!= bp_breakpoint
)
359 error ("Breakpoint #%d does not exist", bpnum
);
361 sal
= find_pc_line (b
->address
, 0);
363 Tcl_DStringAppendElement (result_ptr
, symtab_to_filename (sal
.symtab
));
364 dsprintf_append_element (result_ptr
, "%d", sal
.line
);
365 dsprintf_append_element (result_ptr
, "0x%lx", b
->address
);
366 Tcl_DStringAppendElement (result_ptr
, bptypes
[b
->type
]);
367 Tcl_DStringAppendElement (result_ptr
, b
->enable
== enabled
? "1" : "0");
368 Tcl_DStringAppendElement (result_ptr
, bpdisp
[b
->disposition
]);
369 dsprintf_append_element (result_ptr
, "%d", b
->silent
);
370 dsprintf_append_element (result_ptr
, "%d", b
->ignore_count
);
372 Tcl_DStringStartSublist (result_ptr
);
373 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
374 Tcl_DStringAppendElement (result_ptr
, cmd
->line
);
375 Tcl_DStringEndSublist (result_ptr
);
377 Tcl_DStringAppendElement (result_ptr
, b
->cond_string
);
379 dsprintf_append_element (result_ptr
, "%d", b
->thread
);
380 dsprintf_append_element (result_ptr
, "%d", b
->hit_count
);
386 breakpoint_notify(b
, action
)
387 struct breakpoint
*b
;
393 if (b
->type
!= bp_breakpoint
)
396 /* We ensure that ACTION contains no special Tcl characters, so we
398 sprintf (buf
, "gdbtk_tcl_breakpoint %s %d", action
, b
->number
);
400 v
= Tcl_Eval (interp
, buf
);
404 gdbtk_fputs (interp
->result
, gdb_stdout
);
405 gdbtk_fputs ("\n", gdb_stdout
);
410 gdbtk_create_breakpoint(b
)
411 struct breakpoint
*b
;
413 breakpoint_notify (b
, "create");
417 gdbtk_delete_breakpoint(b
)
418 struct breakpoint
*b
;
420 breakpoint_notify (b
, "delete");
424 gdbtk_modify_breakpoint(b
)
425 struct breakpoint
*b
;
427 breakpoint_notify (b
, "modify");
430 /* This implements the TCL command `gdb_loc', which returns a list consisting
431 of the source and line number associated with the current pc. */
434 gdb_loc (clientData
, interp
, argc
, argv
)
435 ClientData clientData
;
441 struct symtab_and_line sal
;
447 pc
= selected_frame
? selected_frame
->pc
: stop_pc
;
448 sal
= find_pc_line (pc
, 0);
452 struct symtabs_and_lines sals
;
455 sals
= decode_line_spec (argv
[1], 1);
462 error ("Ambiguous line spec");
467 error ("wrong # args");
470 Tcl_DStringAppendElement (result_ptr
, sal
.symtab
->filename
);
472 Tcl_DStringAppendElement (result_ptr
, "");
474 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
475 Tcl_DStringAppendElement (result_ptr
, funcname
);
477 filename
= symtab_to_filename (sal
.symtab
);
478 Tcl_DStringAppendElement (result_ptr
, filename
);
480 dsprintf_append_element (result_ptr
, "%d", sal
.line
); /* line number */
482 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(pc
)); /* PC */
487 /* This implements the TCL command `gdb_eval'. */
490 gdb_eval (clientData
, interp
, argc
, argv
)
491 ClientData clientData
;
496 struct expression
*expr
;
497 struct cleanup
*old_chain
;
501 error ("wrong # args");
503 expr
= parse_expression (argv
[1]);
505 old_chain
= make_cleanup (free_current_contents
, &expr
);
507 val
= evaluate_expression (expr
);
509 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
510 gdb_stdout
, 0, 0, 0, 0);
512 do_cleanups (old_chain
);
517 /* This implements the TCL command `gdb_sourcelines', which returns a list of
518 all of the lines containing executable code for the specified source file
519 (ie: lines where you can put breakpoints). */
522 gdb_sourcelines (clientData
, interp
, argc
, argv
)
523 ClientData clientData
;
528 struct symtab
*symtab
;
529 struct linetable_entry
*le
;
533 error ("wrong # args");
535 symtab
= lookup_symtab (argv
[1]);
538 error ("No such file");
540 /* If there's no linetable, or no entries, then we are done. */
542 if (!symtab
->linetable
543 || symtab
->linetable
->nitems
== 0)
545 Tcl_DStringAppendElement (result_ptr
, "");
549 le
= symtab
->linetable
->item
;
550 nlines
= symtab
->linetable
->nitems
;
552 for (;nlines
> 0; nlines
--, le
++)
554 /* If the pc of this line is the same as the pc of the next line, then
557 && le
->pc
== (le
+ 1)->pc
)
560 dsprintf_append_element (result_ptr
, "%d", le
->line
);
567 map_arg_registers (argc
, argv
, func
, argp
)
570 void (*func
) PARAMS ((int regnum
, void *argp
));
575 /* Note that the test for a valid register must include checking the
576 reg_names array because NUM_REGS may be allocated for the union of the
577 register sets within a family of related processors. In this case, the
578 trailing entries of reg_names will change depending upon the particular
579 processor being debugged. */
581 if (argc
== 0) /* No args, just do all the regs */
585 && reg_names
[regnum
] != NULL
586 && *reg_names
[regnum
] != '\000';
593 /* Else, list of register #s, just do listed regs */
594 for (; argc
> 0; argc
--, argv
++)
596 regnum
= atoi (*argv
);
600 && reg_names
[regnum
] != NULL
601 && *reg_names
[regnum
] != '\000')
604 error ("bad register number");
611 get_register_name (regnum
, argp
)
613 void *argp
; /* Ignored */
615 Tcl_DStringAppendElement (result_ptr
, reg_names
[regnum
]);
618 /* This implements the TCL command `gdb_regnames', which returns a list of
619 all of the register names. */
622 gdb_regnames (clientData
, interp
, argc
, argv
)
623 ClientData clientData
;
631 return map_arg_registers (argc
, argv
, get_register_name
, NULL
);
634 #ifndef REGISTER_CONVERTIBLE
635 #define REGISTER_CONVERTIBLE(x) (0 != 0)
638 #ifndef REGISTER_CONVERT_TO_VIRTUAL
639 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
642 #ifndef INVALID_FLOAT
643 #define INVALID_FLOAT(x, y) (0 != 0)
647 get_register (regnum
, fp
)
651 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
652 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
653 int format
= (int)fp
;
655 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
657 Tcl_DStringAppendElement (result_ptr
, "Optimized out");
661 /* Convert raw data to virtual format if necessary. */
663 if (REGISTER_CONVERTIBLE (regnum
))
665 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
666 raw_buffer
, virtual_buffer
);
669 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
674 printf_filtered ("0x");
675 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
677 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
678 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
679 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
683 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
684 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
686 Tcl_DStringAppend (result_ptr
, " ", -1);
690 gdb_fetch_registers (clientData
, interp
, argc
, argv
)
691 ClientData clientData
;
699 error ("wrong # args");
707 return map_arg_registers (argc
, argv
, get_register
, (void *) format
);
710 /* This contains the previous values of the registers, since the last call to
711 gdb_changed_register_list. */
713 static char old_regs
[REGISTER_BYTES
];
716 register_changed_p (regnum
, argp
)
718 void *argp
; /* Ignored */
720 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
722 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
725 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
726 REGISTER_RAW_SIZE (regnum
)) == 0)
729 /* Found a changed register. Save new value and return its number. */
731 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
732 REGISTER_RAW_SIZE (regnum
));
734 dsprintf_append_element (result_ptr
, "%d", regnum
);
738 gdb_changed_register_list (clientData
, interp
, argc
, argv
)
739 ClientData clientData
;
747 return map_arg_registers (argc
, argv
, register_changed_p
, NULL
);
750 /* This implements the TCL command `gdb_cmd', which sends its argument into
751 the GDB command scanner. */
754 gdb_cmd (clientData
, interp
, argc
, argv
)
755 ClientData clientData
;
761 error ("wrong # args");
766 execute_command (argv
[1], 1);
768 bpstat_do_actions (&stop_bpstat
);
773 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
774 handles cleanups, and calls to return_to_top_level (usually via error).
775 This is necessary in order to prevent a longjmp out of the bowels of Tk,
776 possibly leaving things in a bad state. Since this routine can be called
777 recursively, it needs to save and restore the contents of the jmp_buf as
781 call_wrapper (clientData
, interp
, argc
, argv
)
782 ClientData clientData
;
788 struct cleanup
*saved_cleanup_chain
;
790 jmp_buf saved_error_return
;
791 Tcl_DString result
, *old_result_ptr
;
793 Tcl_DStringInit (&result
);
794 old_result_ptr
= result_ptr
;
795 result_ptr
= &result
;
797 func
= (Tcl_CmdProc
*)clientData
;
798 memcpy (saved_error_return
, error_return
, sizeof (jmp_buf));
800 saved_cleanup_chain
= save_cleanups ();
802 if (!setjmp (error_return
))
803 val
= func (clientData
, interp
, argc
, argv
);
806 val
= TCL_ERROR
; /* Flag an error for TCL */
808 gdb_flush (gdb_stderr
); /* Flush error output */
810 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
812 /* In case of an error, we may need to force the GUI into idle
813 mode because gdbtk_call_command may have bombed out while in
814 the command routine. */
816 Tcl_Eval (interp
, "gdbtk_tcl_idle");
819 do_cleanups (ALL_CLEANUPS
);
821 restore_cleanups (saved_cleanup_chain
);
823 memcpy (error_return
, saved_error_return
, sizeof (jmp_buf));
825 Tcl_DStringResult (interp
, &result
);
826 result_ptr
= old_result_ptr
;
832 gdb_listfiles (clientData
, interp
, argc
, argv
)
833 ClientData clientData
;
838 struct objfile
*objfile
;
839 struct partial_symtab
*psymtab
;
840 struct symtab
*symtab
;
842 ALL_PSYMTABS (objfile
, psymtab
)
843 Tcl_DStringAppendElement (result_ptr
, psymtab
->filename
);
845 ALL_SYMTABS (objfile
, symtab
)
846 Tcl_DStringAppendElement (result_ptr
, symtab
->filename
);
852 gdb_stop (clientData
, interp
, argc
, argv
)
853 ClientData clientData
;
863 /* This implements the TCL command `gdb_disassemble'. */
866 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
870 disassemble_info
*info
;
872 extern struct target_ops exec_ops
;
876 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
887 /* We need a different sort of line table from the normal one cuz we can't
888 depend upon implicit line-end pc's for lines. This is because of the
889 reordering we are about to do. */
891 struct my_line_entry
{
898 compare_lines (mle1p
, mle2p
)
902 struct my_line_entry
*mle1
, *mle2
;
905 mle1
= (struct my_line_entry
*) mle1p
;
906 mle2
= (struct my_line_entry
*) mle2p
;
908 val
= mle1
->line
- mle2
->line
;
913 return mle1
->start_pc
- mle2
->start_pc
;
917 gdb_disassemble (clientData
, interp
, argc
, argv
)
918 ClientData clientData
;
923 CORE_ADDR pc
, low
, high
;
924 int mixed_source_and_assembly
;
925 static disassemble_info di
;
926 static int di_initialized
;
928 if (! di_initialized
)
930 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
931 (fprintf_ftype
) fprintf_unfiltered
);
932 di
.flavour
= bfd_target_unknown_flavour
;
933 di
.memory_error_func
= dis_asm_memory_error
;
934 di
.print_address_func
= dis_asm_print_address
;
938 di
.mach
= tm_print_insn_info
.mach
;
939 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
940 tm_print_insn_info
.endian
= BFD_ENDIAN_BIG
;
942 tm_print_insn_info
.endian
= BFD_ENDIAN_LITTLE
;
944 if (argc
!= 3 && argc
!= 4)
945 error ("wrong # args");
947 if (strcmp (argv
[1], "source") == 0)
948 mixed_source_and_assembly
= 1;
949 else if (strcmp (argv
[1], "nosource") == 0)
950 mixed_source_and_assembly
= 0;
952 error ("First arg must be 'source' or 'nosource'");
954 low
= parse_and_eval_address (argv
[2]);
958 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
959 error ("No function contains specified address");
962 high
= parse_and_eval_address (argv
[3]);
964 /* If disassemble_from_exec == -1, then we use the following heuristic to
965 determine whether or not to do disassembly from target memory or from the
968 If we're debugging a local process, read target memory, instead of the
969 exec file. This makes disassembly of functions in shared libs work
972 Else, we're debugging a remote process, and should disassemble from the
973 exec file for speed. However, this is no good if the target modifies its
974 code (for relocation, or whatever).
977 if (disassemble_from_exec
== -1)
978 if (strcmp (target_shortname
, "child") == 0
979 || strcmp (target_shortname
, "procfs") == 0
980 || strcmp (target_shortname
, "vxprocess") == 0)
981 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
983 disassemble_from_exec
= 1; /* It's remote, read the exec file */
985 if (disassemble_from_exec
)
986 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
988 di
.read_memory_func
= dis_asm_read_memory
;
990 /* If just doing straight assembly, all we need to do is disassemble
991 everything between low and high. If doing mixed source/assembly, we've
992 got a totally different path to follow. */
994 if (mixed_source_and_assembly
)
995 { /* Come here for mixed source/assembly */
996 /* The idea here is to present a source-O-centric view of a function to
997 the user. This means that things are presented in source order, with
998 (possibly) out of order assembly immediately following. */
999 struct symtab
*symtab
;
1000 struct linetable_entry
*le
;
1003 struct my_line_entry
*mle
;
1004 struct symtab_and_line sal
;
1009 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
1014 /* First, convert the linetable to a bunch of my_line_entry's. */
1016 le
= symtab
->linetable
->item
;
1017 nlines
= symtab
->linetable
->nitems
;
1022 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
1026 /* Copy linetable entries for this function into our data structure, creating
1027 end_pc's and setting out_of_order as appropriate. */
1029 /* First, skip all the preceding functions. */
1031 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
1033 /* Now, copy all entries before the end of this function. */
1036 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
1038 if (le
[i
].line
== le
[i
+ 1].line
1039 && le
[i
].pc
== le
[i
+ 1].pc
)
1040 continue; /* Ignore duplicates */
1042 mle
[newlines
].line
= le
[i
].line
;
1043 if (le
[i
].line
> le
[i
+ 1].line
)
1045 mle
[newlines
].start_pc
= le
[i
].pc
;
1046 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
1050 /* If we're on the last line, and it's part of the function, then we need to
1051 get the end pc in a special way. */
1056 mle
[newlines
].line
= le
[i
].line
;
1057 mle
[newlines
].start_pc
= le
[i
].pc
;
1058 sal
= find_pc_line (le
[i
].pc
, 0);
1059 mle
[newlines
].end_pc
= sal
.end
;
1063 /* Now, sort mle by line #s (and, then by addresses within lines). */
1066 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
1068 /* Now, for each line entry, emit the specified lines (unless they have been
1069 emitted before), followed by the assembly code for that line. */
1071 next_line
= 0; /* Force out first line */
1072 for (i
= 0; i
< newlines
; i
++)
1074 /* Print out everything from next_line to the current line. */
1076 if (mle
[i
].line
>= next_line
)
1079 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
1081 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
1083 next_line
= mle
[i
].line
+ 1;
1086 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
1089 fputs_unfiltered (" ", gdb_stdout
);
1090 print_address (pc
, gdb_stdout
);
1091 fputs_unfiltered (":\t ", gdb_stdout
);
1092 pc
+= (*tm_print_insn
) (pc
, &di
);
1093 fputs_unfiltered ("\n", gdb_stdout
);
1100 for (pc
= low
; pc
< high
; )
1103 fputs_unfiltered (" ", gdb_stdout
);
1104 print_address (pc
, gdb_stdout
);
1105 fputs_unfiltered (":\t ", gdb_stdout
);
1106 pc
+= (*tm_print_insn
) (pc
, &di
);
1107 fputs_unfiltered ("\n", gdb_stdout
);
1111 gdb_flush (gdb_stdout
);
1117 tk_command (cmd
, from_tty
)
1123 struct cleanup
*old_chain
;
1125 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1127 error_no_arg ("tcl command to interpret");
1129 retval
= Tcl_Eval (interp
, cmd
);
1131 result
= strdup (interp
->result
);
1133 old_chain
= make_cleanup (free
, result
);
1135 if (retval
!= TCL_OK
)
1138 printf_unfiltered ("%s\n", result
);
1140 do_cleanups (old_chain
);
1144 cleanup_init (ignored
)
1148 Tcl_DeleteInterp (interp
);
1152 /* Come here during long calculations to check for GUI events. Usually invoked
1153 via the QUIT macro. */
1156 gdbtk_interactive ()
1158 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1161 /* Come here when there is activity on the X file descriptor. */
1167 /* Process pending events */
1169 while (Tk_DoOneEvent (TK_DONT_WAIT
|TK_ALL_EVENTS
) != 0);
1173 gdbtk_wait (pid
, ourstatus
)
1175 struct target_waitstatus
*ourstatus
;
1177 struct sigaction action
;
1178 static sigset_t nullsigmask
= {0};
1181 /* Needed for SunOS 4.1.x */
1182 #define SA_RESTART 0
1185 action
.sa_handler
= x_event
;
1186 action
.sa_mask
= nullsigmask
;
1187 action
.sa_flags
= SA_RESTART
;
1188 sigaction(SIGIO
, &action
, NULL
);
1190 pid
= target_wait (pid
, ourstatus
);
1192 action
.sa_handler
= SIG_IGN
;
1193 sigaction(SIGIO
, &action
, NULL
);
1198 /* This is called from execute_command, and provides a wrapper around
1199 various command routines in a place where both protocol messages and
1200 user input both flow through. Mostly this is used for indicating whether
1201 the target process is running or not.
1205 gdbtk_call_command (cmdblk
, arg
, from_tty
)
1206 struct cmd_list_element
*cmdblk
;
1211 if (cmdblk
->class == class_run
)
1214 Tcl_Eval (interp
, "gdbtk_tcl_busy");
1215 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1216 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1220 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1223 /* This function is called instead of gdb's internal command loop. This is the
1224 last chance to do anything before entering the main Tk event loop. */
1229 extern GDB_FILE
*instream
;
1231 /* We no longer want to use stdin as the command input stream */
1233 Tcl_Eval (interp
, "gdbtk_tcl_preloop");
1240 struct cleanup
*old_chain
;
1241 char *gdbtk_filename
;
1243 struct sigaction action
;
1244 static sigset_t nullsigmask
= {0};
1246 /* If there is no DISPLAY environment variable, Tk_Init below will fail,
1247 causing gdb to abort. If instead we simply return here, gdb will
1248 gracefully degrade to using the command line interface. */
1250 if (getenv ("DISPLAY") == NULL
)
1253 old_chain
= make_cleanup (cleanup_init
, 0);
1255 /* First init tcl and tk. */
1257 interp
= Tcl_CreateInterp ();
1260 error ("Tcl_CreateInterp failed");
1262 if (Tcl_Init(interp
) != TCL_OK
)
1263 error ("Tcl_Init failed: %s", interp
->result
);
1265 if (Tk_Init(interp
) != TCL_OK
)
1266 error ("Tk_Init failed: %s", interp
->result
);
1268 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
1269 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
1270 Tcl_CreateCommand (interp
, "gdb_sourcelines", call_wrapper
, gdb_sourcelines
,
1272 Tcl_CreateCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
,
1274 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
1275 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
1276 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
1277 gdb_fetch_registers
, NULL
);
1278 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
1279 gdb_changed_register_list
, NULL
);
1280 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
1281 gdb_disassemble
, NULL
);
1282 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
1283 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
1284 gdb_get_breakpoint_list
, NULL
);
1285 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
1286 gdb_get_breakpoint_info
, NULL
);
1288 command_loop_hook
= tk_command_loop
;
1289 print_frame_info_listing_hook
=
1290 (void (*) PARAMS ((struct symtab
*, int, int, int))) null_routine
;
1291 query_hook
= gdbtk_query
;
1292 flush_hook
= gdbtk_flush
;
1293 create_breakpoint_hook
= gdbtk_create_breakpoint
;
1294 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
1295 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
1296 interactive_hook
= gdbtk_interactive
;
1297 target_wait_hook
= gdbtk_wait
;
1298 call_command_hook
= gdbtk_call_command
;
1299 readline_begin_hook
= gdbtk_readline_begin
;
1300 readline_hook
= gdbtk_readline
;
1301 readline_end_hook
= gdbtk_readline_end
;
1303 /* Get the file descriptor for the X server */
1305 x_fd
= ConnectionNumber (Tk_Display (Tk_MainWindow (interp
)));
1307 /* Setup for I/O interrupts */
1309 action
.sa_mask
= nullsigmask
;
1310 action
.sa_flags
= 0;
1311 action
.sa_handler
= SIG_IGN
;
1312 sigaction(SIGIO
, &action
, NULL
);
1316 if (ioctl (x_fd
, FIOASYNC
, &i
))
1317 perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1321 if (ioctl (x_fd
, SIOCSPGRP
, &i
))
1322 perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1327 if (fcntl (x_fd
, F_SETOWN
, i
))
1328 perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
1329 #endif /* F_SETOWN */
1330 #endif /* !SIOCSPGRP */
1332 if (ioctl (x_fd
, I_SETSIG
, S_INPUT
|S_RDNORM
) < 0)
1333 perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1334 #endif /* ifndef FIOASYNC */
1336 add_com ("tk", class_obscure
, tk_command
,
1337 "Send a command directly into tk.");
1339 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
1342 /* Load up gdbtk.tcl after all the environment stuff has been setup. */
1344 gdbtk_filename
= getenv ("GDBTK_FILENAME");
1345 if (!gdbtk_filename
)
1346 if (access ("gdbtk.tcl", R_OK
) == 0)
1347 gdbtk_filename
= "gdbtk.tcl";
1349 gdbtk_filename
= GDBTK_FILENAME
;
1351 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
1352 prior to this point go to stdout/stderr. */
1354 fputs_unfiltered_hook
= gdbtk_fputs
;
1356 if (Tcl_EvalFile (interp
, gdbtk_filename
) != TCL_OK
)
1358 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
1360 fprintf_unfiltered (stderr
, "%s:%d: %s\n", gdbtk_filename
,
1361 interp
->errorLine
, interp
->result
);
1363 fputs_unfiltered ("Stack trace:\n", gdb_stderr
);
1364 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
1368 discard_cleanups (old_chain
);
1371 /* Come here during initialize_all_files () */
1374 _initialize_gdbtk ()
1378 /* Tell the rest of the world that Gdbtk is now set up. */
1380 init_ui_hook
= gdbtk_init
;