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 /* Handle for TCL interpreter */
60 static Tcl_Interp
*interp
= NULL
;
62 /* Handle for TK main window */
64 static Tk_Window mainWindow
= NULL
;
66 static int x_fd
; /* X network socket */
68 /* This variable is true when the inferior is running. Although it's
69 possible to disable most input from widgets and thus prevent
70 attempts to do anything while the inferior is running, any commands
71 that get through - even a simple memory read - are Very Bad, and
72 may cause GDB to crash or behave strangely. So, this variable
73 provides an extra layer of defense. */
75 static int running_now
;
77 /* This variable determines where memory used for disassembly is read from.
78 If > 0, then disassembly comes from the exec file rather than the
79 target (which might be at the other end of a slow serial link). If
80 == 0 then disassembly comes from target. If < 0 disassembly is
81 automatically switched to the target if it's an inferior process,
82 otherwise the exec file is used. */
84 static int disassemble_from_exec
= -1;
86 /* Supply malloc calls for tcl/tk. */
92 return xmalloc (size
);
96 Tcl_Realloc (ptr
, size
)
100 return xrealloc (ptr
, size
);
116 /* The following routines deal with stdout/stderr data, which is created by
117 {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the
118 lowest level of these routines and capture all output from the rest of GDB.
119 Normally they present their data to tcl via callbacks to the following tcl
120 routines: gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush. These
121 in turn call tk routines to update the display.
123 Under some circumstances, you may want to collect the output so that it can
124 be returned as the value of a tcl procedure. This can be done by
125 surrounding the output routines with calls to start_saving_output and
126 finish_saving_output. The saved data can then be retrieved with
127 get_saved_output (but this must be done before the call to
128 finish_saving_output). */
130 /* Dynamic string header for stdout. */
132 static Tcl_DString
*result_ptr
;
139 /* Force immediate screen update */
141 Tcl_VarEval (interp
, "gdbtk_tcl_flush", NULL
);
146 gdbtk_fputs (ptr
, stream
)
152 Tcl_DStringAppend (result_ptr
, (char *)ptr
, -1);
157 Tcl_DStringInit (&str
);
159 Tcl_DStringAppend (&str
, "gdbtk_tcl_fputs", -1);
160 Tcl_DStringAppendElement (&str
, (char *)ptr
);
162 Tcl_Eval (interp
, Tcl_DStringValue (&str
));
163 Tcl_DStringFree (&str
);
168 gdbtk_query (query
, args
)
172 char buf
[200], *merge
[2];
176 vsprintf (buf
, query
, args
);
177 merge
[0] = "gdbtk_tcl_query";
179 command
= Tcl_Merge (2, merge
);
180 Tcl_Eval (interp
, command
);
183 val
= atol (interp
->result
);
189 #ifdef ANSI_PROTOTYPES
190 gdbtk_readline_begin (char *format
, ...)
192 gdbtk_readline_begin (va_alist
)
197 char buf
[200], *merge
[2];
200 #ifdef ANSI_PROTOTYPES
201 va_start (args
, format
);
205 format
= va_arg (args
, char *);
208 vsprintf (buf
, format
, args
);
209 merge
[0] = "gdbtk_tcl_readline_begin";
211 command
= Tcl_Merge (2, merge
);
212 Tcl_Eval (interp
, command
);
217 gdbtk_readline (prompt
)
223 merge
[0] = "gdbtk_tcl_readline";
225 command
= Tcl_Merge (2, merge
);
226 if (Tcl_Eval (interp
, command
) == TCL_OK
)
228 return (strdup (interp
-> result
));
232 gdbtk_fputs (interp
-> result
, gdb_stdout
);
233 gdbtk_fputs ("\n", gdb_stdout
);
239 gdbtk_readline_end ()
241 Tcl_Eval (interp
, "gdbtk_tcl_readline_end");
246 #ifdef ANSI_PROTOTYPES
247 dsprintf_append_element (Tcl_DString
*dsp
, char *format
, ...)
249 dsprintf_append_element (va_alist
)
256 #ifdef ANSI_PROTOTYPES
257 va_start (args
, format
);
263 dsp
= va_arg (args
, Tcl_DString
*);
264 format
= va_arg (args
, char *);
267 vsprintf (buf
, format
, args
);
269 Tcl_DStringAppendElement (dsp
, buf
);
273 gdb_get_breakpoint_list (clientData
, interp
, argc
, argv
)
274 ClientData clientData
;
279 struct breakpoint
*b
;
280 extern struct breakpoint
*breakpoint_chain
;
283 error ("wrong # args");
285 for (b
= breakpoint_chain
; b
; b
= b
->next
)
286 if (b
->type
== bp_breakpoint
)
287 dsprintf_append_element (result_ptr
, "%d", b
->number
);
293 gdb_get_breakpoint_info (clientData
, interp
, argc
, argv
)
294 ClientData clientData
;
299 struct symtab_and_line sal
;
300 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
301 "finish", "watchpoint", "hardware watchpoint",
302 "read watchpoint", "access watchpoint",
303 "longjmp", "longjmp resume", "step resume",
304 "through sigtramp", "watchpoint scope",
306 static char *bpdisp
[] = {"delete", "disable", "donttouch"};
307 struct command_line
*cmd
;
309 struct breakpoint
*b
;
310 extern struct breakpoint
*breakpoint_chain
;
313 error ("wrong # args");
315 bpnum
= atoi (argv
[1]);
317 for (b
= breakpoint_chain
; b
; b
= b
->next
)
318 if (b
->number
== bpnum
)
321 if (!b
|| b
->type
!= bp_breakpoint
)
322 error ("Breakpoint #%d does not exist", bpnum
);
324 sal
= find_pc_line (b
->address
, 0);
326 Tcl_DStringAppendElement (result_ptr
, symtab_to_filename (sal
.symtab
));
327 dsprintf_append_element (result_ptr
, "%d", sal
.line
);
328 dsprintf_append_element (result_ptr
, "0x%lx", b
->address
);
329 Tcl_DStringAppendElement (result_ptr
, bptypes
[b
->type
]);
330 Tcl_DStringAppendElement (result_ptr
, b
->enable
== enabled
? "1" : "0");
331 Tcl_DStringAppendElement (result_ptr
, bpdisp
[b
->disposition
]);
332 dsprintf_append_element (result_ptr
, "%d", b
->silent
);
333 dsprintf_append_element (result_ptr
, "%d", b
->ignore_count
);
335 Tcl_DStringStartSublist (result_ptr
);
336 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
337 Tcl_DStringAppendElement (result_ptr
, cmd
->line
);
338 Tcl_DStringEndSublist (result_ptr
);
340 Tcl_DStringAppendElement (result_ptr
, b
->cond_string
);
342 dsprintf_append_element (result_ptr
, "%d", b
->thread
);
343 dsprintf_append_element (result_ptr
, "%d", b
->hit_count
);
349 breakpoint_notify(b
, action
)
350 struct breakpoint
*b
;
356 if (b
->type
!= bp_breakpoint
)
359 /* We ensure that ACTION contains no special Tcl characters, so we
361 sprintf (buf
, "gdbtk_tcl_breakpoint %s %d", action
, b
->number
);
363 v
= Tcl_Eval (interp
, buf
);
367 gdbtk_fputs (interp
->result
, gdb_stdout
);
368 gdbtk_fputs ("\n", gdb_stdout
);
373 gdbtk_create_breakpoint(b
)
374 struct breakpoint
*b
;
376 breakpoint_notify (b
, "create");
380 gdbtk_delete_breakpoint(b
)
381 struct breakpoint
*b
;
383 breakpoint_notify (b
, "delete");
387 gdbtk_modify_breakpoint(b
)
388 struct breakpoint
*b
;
390 breakpoint_notify (b
, "modify");
393 /* This implements the TCL command `gdb_loc', which returns a list consisting
394 of the source and line number associated with the current pc. */
397 gdb_loc (clientData
, interp
, argc
, argv
)
398 ClientData clientData
;
404 struct symtab_and_line sal
;
410 pc
= selected_frame
? selected_frame
->pc
: stop_pc
;
411 sal
= find_pc_line (pc
, 0);
415 struct symtabs_and_lines sals
;
418 sals
= decode_line_spec (argv
[1], 1);
425 error ("Ambiguous line spec");
430 error ("wrong # args");
433 Tcl_DStringAppendElement (result_ptr
, sal
.symtab
->filename
);
435 Tcl_DStringAppendElement (result_ptr
, "");
437 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
438 Tcl_DStringAppendElement (result_ptr
, funcname
);
440 filename
= symtab_to_filename (sal
.symtab
);
441 Tcl_DStringAppendElement (result_ptr
, filename
);
443 dsprintf_append_element (result_ptr
, "%d", sal
.line
); /* line number */
445 dsprintf_append_element (result_ptr
, "0x%lx", pc
); /* PC */
450 /* This implements the TCL command `gdb_eval'. */
453 gdb_eval (clientData
, interp
, argc
, argv
)
454 ClientData clientData
;
459 struct expression
*expr
;
460 struct cleanup
*old_chain
;
464 error ("wrong # args");
466 expr
= parse_expression (argv
[1]);
468 old_chain
= make_cleanup (free_current_contents
, &expr
);
470 val
= evaluate_expression (expr
);
472 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
473 gdb_stdout
, 0, 0, 0, 0);
475 do_cleanups (old_chain
);
480 /* This implements the TCL command `gdb_sourcelines', which returns a list of
481 all of the lines containing executable code for the specified source file
482 (ie: lines where you can put breakpoints). */
485 gdb_sourcelines (clientData
, interp
, argc
, argv
)
486 ClientData clientData
;
491 struct symtab
*symtab
;
492 struct linetable_entry
*le
;
496 error ("wrong # args");
498 symtab
= lookup_symtab (argv
[1]);
501 error ("No such file");
503 /* If there's no linetable, or no entries, then we are done. */
505 if (!symtab
->linetable
506 || symtab
->linetable
->nitems
== 0)
508 Tcl_DStringAppendElement (result_ptr
, "");
512 le
= symtab
->linetable
->item
;
513 nlines
= symtab
->linetable
->nitems
;
515 for (;nlines
> 0; nlines
--, le
++)
517 /* If the pc of this line is the same as the pc of the next line, then
520 && le
->pc
== (le
+ 1)->pc
)
523 dsprintf_append_element (result_ptr
, "%d", le
->line
);
530 map_arg_registers (argc
, argv
, func
, argp
)
533 void (*func
) PARAMS ((int regnum
, void *argp
));
538 /* Note that the test for a valid register must include checking the
539 reg_names array because NUM_REGS may be allocated for the union of the
540 register sets within a family of related processors. In this case, the
541 trailing entries of reg_names will change depending upon the particular
542 processor being debugged. */
544 if (argc
== 0) /* No args, just do all the regs */
548 && reg_names
[regnum
] != NULL
549 && *reg_names
[regnum
] != '\000';
556 /* Else, list of register #s, just do listed regs */
557 for (; argc
> 0; argc
--, argv
++)
559 regnum
= atoi (*argv
);
563 && reg_names
[regnum
] != NULL
564 && *reg_names
[regnum
] != '\000')
567 error ("bad register number");
574 get_register_name (regnum
, argp
)
576 void *argp
; /* Ignored */
578 Tcl_DStringAppendElement (result_ptr
, reg_names
[regnum
]);
581 /* This implements the TCL command `gdb_regnames', which returns a list of
582 all of the register names. */
585 gdb_regnames (clientData
, interp
, argc
, argv
)
586 ClientData clientData
;
594 return map_arg_registers (argc
, argv
, get_register_name
, 0);
597 #ifndef REGISTER_CONVERTIBLE
598 #define REGISTER_CONVERTIBLE(x) (0 != 0)
601 #ifndef REGISTER_CONVERT_TO_VIRTUAL
602 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
605 #ifndef INVALID_FLOAT
606 #define INVALID_FLOAT(x, y) (0 != 0)
610 get_register (regnum
, fp
)
614 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
615 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
616 int format
= (int)fp
;
618 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
620 Tcl_DStringAppendElement (result_ptr
, "Optimized out");
624 /* Convert raw data to virtual format if necessary. */
626 if (REGISTER_CONVERTIBLE (regnum
))
628 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
629 raw_buffer
, virtual_buffer
);
632 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
634 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
635 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
637 Tcl_DStringAppend (result_ptr
, " ", -1);
641 gdb_fetch_registers (clientData
, interp
, argc
, argv
)
642 ClientData clientData
;
650 error ("wrong # args");
658 return map_arg_registers (argc
, argv
, get_register
, format
);
661 /* This contains the previous values of the registers, since the last call to
662 gdb_changed_register_list. */
664 static char old_regs
[REGISTER_BYTES
];
667 register_changed_p (regnum
, argp
)
669 void *argp
; /* Ignored */
671 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
674 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
677 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
678 REGISTER_RAW_SIZE (regnum
)) == 0)
681 /* Found a changed register. Save new value and return its number. */
683 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
684 REGISTER_RAW_SIZE (regnum
));
686 dsprintf_append_element (result_ptr
, "%d", regnum
);
690 gdb_changed_register_list (clientData
, interp
, argc
, argv
)
691 ClientData clientData
;
699 return map_arg_registers (argc
, argv
, register_changed_p
, NULL
);
702 /* This implements the TCL command `gdb_cmd', which sends its argument into
703 the GDB command scanner. */
706 gdb_cmd (clientData
, interp
, argc
, argv
)
707 ClientData clientData
;
713 error ("wrong # args");
718 execute_command (argv
[1], 1);
720 bpstat_do_actions (&stop_bpstat
);
725 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
726 handles cleanups, and calls to return_to_top_level (usually via error).
727 This is necessary in order to prevent a longjmp out of the bowels of Tk,
728 possibly leaving things in a bad state. Since this routine can be called
729 recursively, it needs to save and restore the contents of the jmp_buf as
733 call_wrapper (clientData
, interp
, argc
, argv
)
734 ClientData clientData
;
740 struct cleanup
*saved_cleanup_chain
;
742 jmp_buf saved_error_return
;
743 Tcl_DString result
, *old_result_ptr
;
745 Tcl_DStringInit (&result
);
746 old_result_ptr
= result_ptr
;
747 result_ptr
= &result
;
749 func
= (Tcl_CmdProc
*)clientData
;
750 memcpy (saved_error_return
, error_return
, sizeof (jmp_buf));
752 saved_cleanup_chain
= save_cleanups ();
754 if (!setjmp (error_return
))
755 val
= func (clientData
, interp
, argc
, argv
);
758 val
= TCL_ERROR
; /* Flag an error for TCL */
760 gdb_flush (gdb_stderr
); /* Flush error output */
762 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
764 /* In case of an error, we may need to force the GUI into idle
765 mode because gdbtk_call_command may have bombed out while in
766 the command routine. */
768 Tcl_Eval (interp
, "gdbtk_tcl_idle");
771 do_cleanups (ALL_CLEANUPS
);
773 restore_cleanups (saved_cleanup_chain
);
775 memcpy (error_return
, saved_error_return
, sizeof (jmp_buf));
777 Tcl_DStringResult (interp
, &result
);
778 result_ptr
= old_result_ptr
;
784 gdb_listfiles (clientData
, interp
, argc
, argv
)
785 ClientData clientData
;
790 struct objfile
*objfile
;
791 struct partial_symtab
*psymtab
;
792 struct symtab
*symtab
;
794 ALL_PSYMTABS (objfile
, psymtab
)
795 Tcl_DStringAppendElement (result_ptr
, psymtab
->filename
);
797 ALL_SYMTABS (objfile
, symtab
)
798 Tcl_DStringAppendElement (result_ptr
, symtab
->filename
);
804 gdb_stop (clientData
, interp
, argc
, argv
)
805 ClientData clientData
;
815 /* This implements the TCL command `gdb_disassemble'. */
818 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
822 disassemble_info
*info
;
824 extern struct target_ops exec_ops
;
828 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
839 /* We need a different sort of line table from the normal one cuz we can't
840 depend upon implicit line-end pc's for lines. This is because of the
841 reordering we are about to do. */
843 struct my_line_entry
{
850 compare_lines (mle1p
, mle2p
)
854 struct my_line_entry
*mle1
, *mle2
;
857 mle1
= (struct my_line_entry
*) mle1p
;
858 mle2
= (struct my_line_entry
*) mle2p
;
860 val
= mle1
->line
- mle2
->line
;
865 return mle1
->start_pc
- mle2
->start_pc
;
869 gdb_disassemble (clientData
, interp
, argc
, argv
)
870 ClientData clientData
;
875 CORE_ADDR pc
, low
, high
;
876 int mixed_source_and_assembly
;
877 static disassemble_info di
;
878 static int di_initialized
;
880 if (! di_initialized
)
882 INIT_DISASSEMBLE_INFO (di
, gdb_stdout
,
883 (fprintf_ftype
) fprintf_unfiltered
);
884 di
.memory_error_func
= dis_asm_memory_error
;
885 di
.print_address_func
= dis_asm_print_address
;
889 if (argc
!= 3 && argc
!= 4)
890 error ("wrong # args");
892 if (strcmp (argv
[1], "source") == 0)
893 mixed_source_and_assembly
= 1;
894 else if (strcmp (argv
[1], "nosource") == 0)
895 mixed_source_and_assembly
= 0;
897 error ("First arg must be 'source' or 'nosource'");
899 low
= parse_and_eval_address (argv
[2]);
903 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
904 error ("No function contains specified address");
907 high
= parse_and_eval_address (argv
[3]);
909 /* If disassemble_from_exec == -1, then we use the following heuristic to
910 determine whether or not to do disassembly from target memory or from the
913 If we're debugging a local process, read target memory, instead of the
914 exec file. This makes disassembly of functions in shared libs work
917 Else, we're debugging a remote process, and should disassemble from the
918 exec file for speed. However, this is no good if the target modifies its
919 code (for relocation, or whatever).
922 if (disassemble_from_exec
== -1)
923 if (strcmp (target_shortname
, "child") == 0
924 || strcmp (target_shortname
, "procfs") == 0
925 || strcmp (target_shortname
, "vxprocess") == 0)
926 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
928 disassemble_from_exec
= 1; /* It's remote, read the exec file */
930 if (disassemble_from_exec
)
931 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
933 di
.read_memory_func
= dis_asm_read_memory
;
935 /* If just doing straight assembly, all we need to do is disassemble
936 everything between low and high. If doing mixed source/assembly, we've
937 got a totally different path to follow. */
939 if (mixed_source_and_assembly
)
940 { /* Come here for mixed source/assembly */
941 /* The idea here is to present a source-O-centric view of a function to
942 the user. This means that things are presented in source order, with
943 (possibly) out of order assembly immediately following. */
944 struct symtab
*symtab
;
945 struct linetable_entry
*le
;
948 struct my_line_entry
*mle
;
949 struct symtab_and_line sal
;
954 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
959 /* First, convert the linetable to a bunch of my_line_entry's. */
961 le
= symtab
->linetable
->item
;
962 nlines
= symtab
->linetable
->nitems
;
967 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
971 /* Copy linetable entries for this function into our data structure, creating
972 end_pc's and setting out_of_order as appropriate. */
974 /* First, skip all the preceding functions. */
976 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
978 /* Now, copy all entries before the end of this function. */
981 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
983 if (le
[i
].line
== le
[i
+ 1].line
984 && le
[i
].pc
== le
[i
+ 1].pc
)
985 continue; /* Ignore duplicates */
987 mle
[newlines
].line
= le
[i
].line
;
988 if (le
[i
].line
> le
[i
+ 1].line
)
990 mle
[newlines
].start_pc
= le
[i
].pc
;
991 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
995 /* If we're on the last line, and it's part of the function, then we need to
996 get the end pc in a special way. */
1001 mle
[newlines
].line
= le
[i
].line
;
1002 mle
[newlines
].start_pc
= le
[i
].pc
;
1003 sal
= find_pc_line (le
[i
].pc
, 0);
1004 mle
[newlines
].end_pc
= sal
.end
;
1008 /* Now, sort mle by line #s (and, then by addresses within lines). */
1011 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
1013 /* Now, for each line entry, emit the specified lines (unless they have been
1014 emitted before), followed by the assembly code for that line. */
1016 next_line
= 0; /* Force out first line */
1017 for (i
= 0; i
< newlines
; i
++)
1019 /* Print out everything from next_line to the current line. */
1021 if (mle
[i
].line
>= next_line
)
1024 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
1026 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
1028 next_line
= mle
[i
].line
+ 1;
1031 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
1034 fputs_unfiltered (" ", gdb_stdout
);
1035 print_address (pc
, gdb_stdout
);
1036 fputs_unfiltered (":\t ", gdb_stdout
);
1037 pc
+= (*tm_print_insn
) (pc
, &di
);
1038 fputs_unfiltered ("\n", gdb_stdout
);
1045 for (pc
= low
; pc
< high
; )
1048 fputs_unfiltered (" ", gdb_stdout
);
1049 print_address (pc
, gdb_stdout
);
1050 fputs_unfiltered (":\t ", gdb_stdout
);
1051 pc
+= (*tm_print_insn
) (pc
, &di
);
1052 fputs_unfiltered ("\n", gdb_stdout
);
1056 gdb_flush (gdb_stdout
);
1062 tk_command (cmd
, from_tty
)
1068 struct cleanup
*old_chain
;
1070 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1072 error_no_arg ("tcl command to interpret");
1074 retval
= Tcl_Eval (interp
, cmd
);
1076 result
= strdup (interp
->result
);
1078 old_chain
= make_cleanup (free
, result
);
1080 if (retval
!= TCL_OK
)
1083 printf_unfiltered ("%s\n", result
);
1085 do_cleanups (old_chain
);
1089 cleanup_init (ignored
)
1092 if (mainWindow
!= NULL
)
1093 Tk_DestroyWindow (mainWindow
);
1097 Tcl_DeleteInterp (interp
);
1101 /* Come here during long calculations to check for GUI events. Usually invoked
1102 via the QUIT macro. */
1105 gdbtk_interactive ()
1107 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1110 /* Come here when there is activity on the X file descriptor. */
1116 /* Process pending events */
1118 while (Tk_DoOneEvent (TK_DONT_WAIT
|TK_ALL_EVENTS
) != 0);
1122 gdbtk_wait (pid
, ourstatus
)
1124 struct target_waitstatus
*ourstatus
;
1126 struct sigaction action
;
1127 static sigset_t nullsigmask
= {0};
1130 /* Needed for SunOS 4.1.x */
1131 #define SA_RESTART 0
1134 action
.sa_handler
= x_event
;
1135 action
.sa_mask
= nullsigmask
;
1136 action
.sa_flags
= SA_RESTART
;
1137 sigaction(SIGIO
, &action
, NULL
);
1139 pid
= target_wait (pid
, ourstatus
);
1141 action
.sa_handler
= SIG_IGN
;
1142 sigaction(SIGIO
, &action
, NULL
);
1147 /* This is called from execute_command, and provides a wrapper around
1148 various command routines in a place where both protocol messages and
1149 user input both flow through. Mostly this is used for indicating whether
1150 the target process is running or not.
1154 gdbtk_call_command (cmdblk
, arg
, from_tty
)
1155 struct cmd_list_element
*cmdblk
;
1160 if (cmdblk
->class == class_run
)
1163 Tcl_Eval (interp
, "gdbtk_tcl_busy");
1164 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1165 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1169 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1172 /* This function is called instead of gdb's internal command loop. This is the
1173 last chance to do anything before entering the main Tk event loop. */
1178 extern GDB_FILE
*instream
;
1180 /* We no longer want to use stdin as the command input stream */
1182 Tcl_Eval (interp
, "gdbtk_tcl_preloop");
1189 struct cleanup
*old_chain
;
1190 char *gdbtk_filename
;
1192 struct sigaction action
;
1193 static sigset_t nullsigmask
= {0};
1195 old_chain
= make_cleanup (cleanup_init
, 0);
1197 /* First init tcl and tk. */
1199 interp
= Tcl_CreateInterp ();
1202 error ("Tcl_CreateInterp failed");
1204 mainWindow
= Tk_CreateMainWindow (interp
, NULL
, "gdb", "Gdb");
1207 return; /* DISPLAY probably not set */
1209 if (Tcl_Init(interp
) != TCL_OK
)
1210 error ("Tcl_Init failed: %s", interp
->result
);
1212 if (Tk_Init(interp
) != TCL_OK
)
1213 error ("Tk_Init failed: %s", interp
->result
);
1215 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
1216 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
1217 Tcl_CreateCommand (interp
, "gdb_sourcelines", call_wrapper
, gdb_sourcelines
,
1219 Tcl_CreateCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
,
1221 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
1222 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
1223 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
1224 gdb_fetch_registers
, NULL
);
1225 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
1226 gdb_changed_register_list
, NULL
);
1227 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
1228 gdb_disassemble
, NULL
);
1229 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
1230 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
1231 gdb_get_breakpoint_list
, NULL
);
1232 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
1233 gdb_get_breakpoint_info
, NULL
);
1235 command_loop_hook
= tk_command_loop
;
1236 print_frame_info_listing_hook
= null_routine
;
1237 query_hook
= gdbtk_query
;
1238 flush_hook
= gdbtk_flush
;
1239 create_breakpoint_hook
= gdbtk_create_breakpoint
;
1240 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
1241 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
1242 interactive_hook
= gdbtk_interactive
;
1243 target_wait_hook
= gdbtk_wait
;
1244 call_command_hook
= gdbtk_call_command
;
1245 readline_begin_hook
= gdbtk_readline_begin
;
1246 readline_hook
= gdbtk_readline
;
1247 readline_end_hook
= gdbtk_readline_end
;
1249 /* Get the file descriptor for the X server */
1251 x_fd
= ConnectionNumber (Tk_Display (mainWindow
));
1253 /* Setup for I/O interrupts */
1255 action
.sa_mask
= nullsigmask
;
1256 action
.sa_flags
= 0;
1257 action
.sa_handler
= SIG_IGN
;
1258 sigaction(SIGIO
, &action
, NULL
);
1262 if (ioctl (x_fd
, FIOASYNC
, &i
))
1263 perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1267 if (ioctl (x_fd
, SIOCSPGRP
, &i
))
1268 perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1273 if (fcntl (x_fd
, F_SETOWN
, i
))
1274 perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
1275 #endif /* F_SETOWN */
1276 #endif /* !SIOCSPGRP */
1278 if (ioctl (x_fd
, I_SETSIG
, S_INPUT
|S_RDNORM
) < 0)
1279 perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1280 #endif /* ifndef FIOASYNC */
1282 add_com ("tk", class_obscure
, tk_command
,
1283 "Send a command directly into tk.");
1285 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
1288 /* Load up gdbtk.tcl after all the environment stuff has been setup. */
1290 gdbtk_filename
= getenv ("GDBTK_FILENAME");
1291 if (!gdbtk_filename
)
1292 if (access ("gdbtk.tcl", R_OK
) == 0)
1293 gdbtk_filename
= "gdbtk.tcl";
1295 gdbtk_filename
= GDBTK_FILENAME
;
1297 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
1298 prior to this point go to stdout/stderr. */
1300 fputs_unfiltered_hook
= gdbtk_fputs
;
1302 if (Tcl_EvalFile (interp
, gdbtk_filename
) != TCL_OK
)
1304 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
1306 fprintf_unfiltered (stderr
, "%s:%d: %s\n", gdbtk_filename
,
1307 interp
->errorLine
, interp
->result
);
1309 fputs_unfiltered ("Stack trace:\n", gdb_stderr
);
1310 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
1314 discard_cleanups (old_chain
);
1317 /* Come here during initialize_all_files () */
1320 _initialize_gdbtk ()
1324 /* Tell the rest of the world that Gdbtk is now set up. */
1326 init_ui_hook
= gdbtk_init
;