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 us 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
);
188 #ifdef ANSI_PROTOTYPES
189 dsprintf_append_element (Tcl_DString
*dsp
, char *format
, ...)
191 dsprintf_append_element (va_alist
)
198 #ifdef ANSI_PROTOTYPES
199 va_start (args
, format
);
205 dsp
= va_arg (args
, Tcl_DString
*);
206 format
= va_arg (args
, char *);
209 vsprintf (buf
, format
, args
);
211 Tcl_DStringAppendElement (dsp
, buf
);
215 gdb_get_breakpoint_list (clientData
, interp
, argc
, argv
)
216 ClientData clientData
;
221 struct breakpoint
*b
;
222 extern struct breakpoint
*breakpoint_chain
;
225 error ("wrong # args");
227 for (b
= breakpoint_chain
; b
; b
= b
->next
)
228 if (b
->type
== bp_breakpoint
)
229 dsprintf_append_element (result_ptr
, "%d", b
->number
);
235 gdb_get_breakpoint_info (clientData
, interp
, argc
, argv
)
236 ClientData clientData
;
241 struct symtab_and_line sal
;
242 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
243 "finish", "watchpoint", "hardware watchpoint",
244 "read watchpoint", "access watchpoint",
245 "longjmp", "longjmp resume", "step resume",
246 "through sigtramp", "watchpoint scope",
248 static char *bpdisp
[] = {"delete", "disable", "donttouch"};
249 struct command_line
*cmd
;
251 struct breakpoint
*b
;
252 extern struct breakpoint
*breakpoint_chain
;
255 error ("wrong # args");
257 bpnum
= atoi (argv
[1]);
259 for (b
= breakpoint_chain
; b
; b
= b
->next
)
260 if (b
->number
== bpnum
)
263 if (!b
|| b
->type
!= bp_breakpoint
)
264 error ("Breakpoint #%d does not exist", bpnum
);
266 sal
= find_pc_line (b
->address
, 0);
268 Tcl_DStringAppendElement (result_ptr
, symtab_to_filename (sal
.symtab
));
269 dsprintf_append_element (result_ptr
, "%d", sal
.line
);
270 dsprintf_append_element (result_ptr
, "0x%lx", b
->address
);
271 Tcl_DStringAppendElement (result_ptr
, bptypes
[b
->type
]);
272 Tcl_DStringAppendElement (result_ptr
, b
->enable
== enabled
? "1" : "0");
273 Tcl_DStringAppendElement (result_ptr
, bpdisp
[b
->disposition
]);
274 dsprintf_append_element (result_ptr
, "%d", b
->silent
);
275 dsprintf_append_element (result_ptr
, "%d", b
->ignore_count
);
277 Tcl_DStringStartSublist (result_ptr
);
278 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
279 Tcl_DStringAppendElement (result_ptr
, cmd
->line
);
280 Tcl_DStringEndSublist (result_ptr
);
282 Tcl_DStringAppendElement (result_ptr
, b
->cond_string
);
284 dsprintf_append_element (result_ptr
, "%d", b
->thread
);
285 dsprintf_append_element (result_ptr
, "%d", b
->hit_count
);
291 breakpoint_notify(b
, action
)
292 struct breakpoint
*b
;
298 if (b
->type
!= bp_breakpoint
)
301 /* We ensure that ACTION contains no special Tcl characters, so we
303 sprintf (buf
, "gdbtk_tcl_breakpoint %s %d", action
, b
->number
);
305 v
= Tcl_Eval (interp
, buf
);
309 gdbtk_fputs (interp
->result
, gdb_stdout
);
310 gdbtk_fputs ("\n", gdb_stdout
);
315 gdbtk_create_breakpoint(b
)
316 struct breakpoint
*b
;
318 breakpoint_notify (b
, "create");
322 gdbtk_delete_breakpoint(b
)
323 struct breakpoint
*b
;
325 breakpoint_notify (b
, "delete");
329 gdbtk_modify_breakpoint(b
)
330 struct breakpoint
*b
;
332 breakpoint_notify (b
, "modify");
335 /* This implements the TCL command `gdb_loc', which returns a list consisting
336 of the source and line number associated with the current pc. */
339 gdb_loc (clientData
, interp
, argc
, argv
)
340 ClientData clientData
;
346 struct symtab_and_line sal
;
352 pc
= selected_frame
? selected_frame
->pc
: stop_pc
;
353 sal
= find_pc_line (pc
, 0);
357 struct symtabs_and_lines sals
;
360 sals
= decode_line_spec (argv
[1], 1);
367 error ("Ambiguous line spec");
372 error ("wrong # args");
375 Tcl_DStringAppendElement (result_ptr
, sal
.symtab
->filename
);
377 Tcl_DStringAppendElement (result_ptr
, "");
379 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
380 Tcl_DStringAppendElement (result_ptr
, funcname
);
382 filename
= symtab_to_filename (sal
.symtab
);
383 Tcl_DStringAppendElement (result_ptr
, filename
);
385 dsprintf_append_element (result_ptr
, "%d", sal
.line
); /* line number */
387 dsprintf_append_element (result_ptr
, "0x%lx", pc
); /* PC */
392 /* This implements the TCL command `gdb_eval'. */
395 gdb_eval (clientData
, interp
, argc
, argv
)
396 ClientData clientData
;
401 struct expression
*expr
;
402 struct cleanup
*old_chain
;
406 error ("wrong # args");
408 expr
= parse_expression (argv
[1]);
410 old_chain
= make_cleanup (free_current_contents
, &expr
);
412 val
= evaluate_expression (expr
);
414 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
415 gdb_stdout
, 0, 0, 0, 0);
417 do_cleanups (old_chain
);
422 /* This implements the TCL command `gdb_sourcelines', which returns a list of
423 all of the lines containing executable code for the specified source file
424 (ie: lines where you can put breakpoints). */
427 gdb_sourcelines (clientData
, interp
, argc
, argv
)
428 ClientData clientData
;
433 struct symtab
*symtab
;
434 struct linetable_entry
*le
;
438 error ("wrong # args");
440 symtab
= lookup_symtab (argv
[1]);
443 error ("No such file");
445 /* If there's no linetable, or no entries, then we are done. */
447 if (!symtab
->linetable
448 || symtab
->linetable
->nitems
== 0)
450 Tcl_DStringAppendElement (result_ptr
, "");
454 le
= symtab
->linetable
->item
;
455 nlines
= symtab
->linetable
->nitems
;
457 for (;nlines
> 0; nlines
--, le
++)
459 /* If the pc of this line is the same as the pc of the next line, then
462 && le
->pc
== (le
+ 1)->pc
)
465 dsprintf_append_element (result_ptr
, "%d", le
->line
);
472 map_arg_registers (argc
, argv
, func
, argp
)
475 void (*func
) PARAMS ((int regnum
, void *argp
));
480 /* Note that the test for a valid register must include checking the
481 reg_names array because NUM_REGS may be allocated for the union of the
482 register sets within a family of related processors. In this case, the
483 trailing entries of reg_names will change depending upon the particular
484 processor being debugged. */
486 if (argc
== 0) /* No args, just do all the regs */
490 && reg_names
[regnum
] != NULL
491 && *reg_names
[regnum
] != '\000';
498 /* Else, list of register #s, just do listed regs */
499 for (; argc
> 0; argc
--, argv
++)
501 regnum
= atoi (*argv
);
505 && reg_names
[regnum
] != NULL
506 && *reg_names
[regnum
] != '\000')
509 error ("bad register number");
516 get_register_name (regnum
, argp
)
518 void *argp
; /* Ignored */
520 Tcl_DStringAppendElement (result_ptr
, reg_names
[regnum
]);
523 /* This implements the TCL command `gdb_regnames', which returns a list of
524 all of the register names. */
527 gdb_regnames (clientData
, interp
, argc
, argv
)
528 ClientData clientData
;
536 return map_arg_registers (argc
, argv
, get_register_name
, 0);
539 #ifndef REGISTER_CONVERTIBLE
540 #define REGISTER_CONVERTIBLE(x) (0 != 0)
543 #ifndef REGISTER_CONVERT_TO_VIRTUAL
544 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
547 #ifndef INVALID_FLOAT
548 #define INVALID_FLOAT(x, y) (0 != 0)
552 get_register (regnum
, fp
)
556 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
557 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
558 int format
= (int)fp
;
560 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
562 Tcl_DStringAppendElement (result_ptr
, "Optimized out");
566 /* Convert raw data to virtual format if necessary. */
568 if (REGISTER_CONVERTIBLE (regnum
))
570 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
571 raw_buffer
, virtual_buffer
);
574 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
576 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
577 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
579 Tcl_DStringAppend (result_ptr
, " ", -1);
583 gdb_fetch_registers (clientData
, interp
, argc
, argv
)
584 ClientData clientData
;
592 error ("wrong # args");
600 return map_arg_registers (argc
, argv
, get_register
, format
);
603 /* This contains the previous values of the registers, since the last call to
604 gdb_changed_register_list. */
606 static char old_regs
[REGISTER_BYTES
];
609 register_changed_p (regnum
, argp
)
611 void *argp
; /* Ignored */
613 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
616 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
619 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
620 REGISTER_RAW_SIZE (regnum
)) == 0)
623 /* Found a changed register. Save new value and return its number. */
625 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
626 REGISTER_RAW_SIZE (regnum
));
628 dsprintf_append_element (result_ptr
, "%d", regnum
);
632 gdb_changed_register_list (clientData
, interp
, argc
, argv
)
633 ClientData clientData
;
641 return map_arg_registers (argc
, argv
, register_changed_p
, NULL
);
644 /* This implements the TCL command `gdb_cmd', which sends its argument into
645 the GDB command scanner. */
648 gdb_cmd (clientData
, interp
, argc
, argv
)
649 ClientData clientData
;
655 error ("wrong # args");
660 execute_command (argv
[1], 1);
662 bpstat_do_actions (&stop_bpstat
);
667 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
668 handles cleanups, and calls to return_to_top_level (usually via error).
669 This is necessary in order to prevent a longjmp out of the bowels of Tk,
670 possibly leaving things in a bad state. Since this routine can be called
671 recursively, it needs to save and restore the contents of the jmp_buf as
675 call_wrapper (clientData
, interp
, argc
, argv
)
676 ClientData clientData
;
682 struct cleanup
*saved_cleanup_chain
;
684 jmp_buf saved_error_return
;
685 Tcl_DString result
, *old_result_ptr
;
687 Tcl_DStringInit (&result
);
688 old_result_ptr
= result_ptr
;
689 result_ptr
= &result
;
691 func
= (Tcl_CmdProc
*)clientData
;
692 memcpy (saved_error_return
, error_return
, sizeof (jmp_buf));
694 saved_cleanup_chain
= save_cleanups ();
696 if (!setjmp (error_return
))
697 val
= func (clientData
, interp
, argc
, argv
);
700 val
= TCL_ERROR
; /* Flag an error for TCL */
702 gdb_flush (gdb_stderr
); /* Flush error output */
704 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
706 /* In case of an error, we may need to force the GUI into idle
707 mode because gdbtk_call_command may have bombed out while in
708 the command routine. */
710 Tcl_Eval (interp
, "gdbtk_tcl_idle");
713 do_cleanups (ALL_CLEANUPS
);
715 restore_cleanups (saved_cleanup_chain
);
717 memcpy (error_return
, saved_error_return
, sizeof (jmp_buf));
719 Tcl_DStringResult (interp
, &result
);
720 result_ptr
= old_result_ptr
;
726 gdb_listfiles (clientData
, interp
, argc
, argv
)
727 ClientData clientData
;
732 struct objfile
*objfile
;
733 struct partial_symtab
*psymtab
;
734 struct symtab
*symtab
;
736 ALL_PSYMTABS (objfile
, psymtab
)
737 Tcl_DStringAppendElement (result_ptr
, psymtab
->filename
);
739 ALL_SYMTABS (objfile
, symtab
)
740 Tcl_DStringAppendElement (result_ptr
, symtab
->filename
);
746 gdb_stop (clientData
, interp
, argc
, argv
)
747 ClientData clientData
;
757 /* This implements the TCL command `gdb_disassemble'. */
760 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
764 disassemble_info
*info
;
766 extern struct target_ops exec_ops
;
770 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
781 /* We need a different sort of line table from the normal one cuz we can't
782 depend upon implicit line-end pc's for lines. This is because of the
783 reordering we are about to do. */
785 struct my_line_entry
{
792 compare_lines (mle1p
, mle2p
)
796 struct my_line_entry
*mle1
, *mle2
;
799 mle1
= (struct my_line_entry
*) mle1p
;
800 mle2
= (struct my_line_entry
*) mle2p
;
802 val
= mle1
->line
- mle2
->line
;
807 return mle1
->start_pc
- mle2
->start_pc
;
811 gdb_disassemble (clientData
, interp
, argc
, argv
)
812 ClientData clientData
;
817 CORE_ADDR pc
, low
, high
;
818 int mixed_source_and_assembly
;
819 static disassemble_info di
;
820 static int di_initialized
;
822 if (! di_initialized
)
824 INIT_DISASSEMBLE_INFO (di
, gdb_stdout
,
825 (fprintf_ftype
) fprintf_unfiltered
);
826 di
.memory_error_func
= dis_asm_memory_error
;
827 di
.print_address_func
= dis_asm_print_address
;
831 if (argc
!= 3 && argc
!= 4)
832 error ("wrong # args");
834 if (strcmp (argv
[1], "source") == 0)
835 mixed_source_and_assembly
= 1;
836 else if (strcmp (argv
[1], "nosource") == 0)
837 mixed_source_and_assembly
= 0;
839 error ("First arg must be 'source' or 'nosource'");
841 low
= parse_and_eval_address (argv
[2]);
845 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
846 error ("No function contains specified address");
849 high
= parse_and_eval_address (argv
[3]);
851 /* If disassemble_from_exec == -1, then we use the following heuristic to
852 determine whether or not to do disassembly from target memory or from the
855 If we're debugging a local process, read target memory, instead of the
856 exec file. This makes disassembly of functions in shared libs work
859 Else, we're debugging a remote process, and should disassemble from the
860 exec file for speed. However, this is no good if the target modifies its
861 code (for relocation, or whatever).
864 if (disassemble_from_exec
== -1)
865 if (strcmp (target_shortname
, "child") == 0
866 || strcmp (target_shortname
, "procfs") == 0
867 || strcmp (target_shortname
, "vxprocess") == 0)
868 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
870 disassemble_from_exec
= 1; /* It's remote, read the exec file */
872 if (disassemble_from_exec
)
873 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
875 di
.read_memory_func
= dis_asm_read_memory
;
877 /* If just doing straight assembly, all we need to do is disassemble
878 everything between low and high. If doing mixed source/assembly, we've
879 got a totally different path to follow. */
881 if (mixed_source_and_assembly
)
882 { /* Come here for mixed source/assembly */
883 /* The idea here is to present a source-O-centric view of a function to
884 the user. This means that things are presented in source order, with
885 (possibly) out of order assembly immediately following. */
886 struct symtab
*symtab
;
887 struct linetable_entry
*le
;
890 struct my_line_entry
*mle
;
891 struct symtab_and_line sal
;
896 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
901 /* First, convert the linetable to a bunch of my_line_entry's. */
903 le
= symtab
->linetable
->item
;
904 nlines
= symtab
->linetable
->nitems
;
909 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
913 /* Copy linetable entries for this function into our data structure, creating
914 end_pc's and setting out_of_order as appropriate. */
916 /* First, skip all the preceding functions. */
918 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
920 /* Now, copy all entries before the end of this function. */
923 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
925 if (le
[i
].line
== le
[i
+ 1].line
926 && le
[i
].pc
== le
[i
+ 1].pc
)
927 continue; /* Ignore duplicates */
929 mle
[newlines
].line
= le
[i
].line
;
930 if (le
[i
].line
> le
[i
+ 1].line
)
932 mle
[newlines
].start_pc
= le
[i
].pc
;
933 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
937 /* If we're on the last line, and it's part of the function, then we need to
938 get the end pc in a special way. */
943 mle
[newlines
].line
= le
[i
].line
;
944 mle
[newlines
].start_pc
= le
[i
].pc
;
945 sal
= find_pc_line (le
[i
].pc
, 0);
946 mle
[newlines
].end_pc
= sal
.end
;
950 /* Now, sort mle by line #s (and, then by addresses within lines). */
953 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
955 /* Now, for each line entry, emit the specified lines (unless they have been
956 emitted before), followed by the assembly code for that line. */
958 next_line
= 0; /* Force out first line */
959 for (i
= 0; i
< newlines
; i
++)
961 /* Print out everything from next_line to the current line. */
963 if (mle
[i
].line
>= next_line
)
966 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
968 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
970 next_line
= mle
[i
].line
+ 1;
973 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
976 fputs_unfiltered (" ", gdb_stdout
);
977 print_address (pc
, gdb_stdout
);
978 fputs_unfiltered (":\t ", gdb_stdout
);
979 pc
+= (*tm_print_insn
) (pc
, &di
);
980 fputs_unfiltered ("\n", gdb_stdout
);
987 for (pc
= low
; pc
< high
; )
990 fputs_unfiltered (" ", gdb_stdout
);
991 print_address (pc
, gdb_stdout
);
992 fputs_unfiltered (":\t ", gdb_stdout
);
993 pc
+= (*tm_print_insn
) (pc
, &di
);
994 fputs_unfiltered ("\n", gdb_stdout
);
998 gdb_flush (gdb_stdout
);
1004 tk_command (cmd
, from_tty
)
1010 struct cleanup
*old_chain
;
1012 retval
= Tcl_Eval (interp
, cmd
);
1014 result
= strdup (interp
->result
);
1016 old_chain
= make_cleanup (free
, result
);
1018 if (retval
!= TCL_OK
)
1021 printf_unfiltered ("%s\n", result
);
1023 do_cleanups (old_chain
);
1027 cleanup_init (ignored
)
1030 if (mainWindow
!= NULL
)
1031 Tk_DestroyWindow (mainWindow
);
1035 Tcl_DeleteInterp (interp
);
1039 /* Come here during long calculations to check for GUI events. Usually invoked
1040 via the QUIT macro. */
1043 gdbtk_interactive ()
1045 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1048 /* Come here when there is activity on the X file descriptor. */
1054 /* Process pending events */
1056 while (Tk_DoOneEvent (TK_DONT_WAIT
|TK_ALL_EVENTS
) != 0);
1060 gdbtk_wait (pid
, ourstatus
)
1062 struct target_waitstatus
*ourstatus
;
1064 struct sigaction action
;
1065 static sigset_t nullsigmask
= {0};
1068 /* Needed for SunOS 4.1.x */
1069 #define SA_RESTART 0
1072 action
.sa_handler
= x_event
;
1073 action
.sa_mask
= nullsigmask
;
1074 action
.sa_flags
= SA_RESTART
;
1075 sigaction(SIGIO
, &action
, NULL
);
1077 pid
= target_wait (pid
, ourstatus
);
1079 action
.sa_handler
= SIG_IGN
;
1080 sigaction(SIGIO
, &action
, NULL
);
1085 /* This is called from execute_command, and provides a wrapper around
1086 various command routines in a place where both protocol messages and
1087 user input both flow through. Mostly this is used for indicating whether
1088 the target process is running or not.
1092 gdbtk_call_command (cmdblk
, arg
, from_tty
)
1093 struct cmd_list_element
*cmdblk
;
1098 if (cmdblk
->class == class_run
)
1101 Tcl_Eval (interp
, "gdbtk_tcl_busy");
1102 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1103 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1107 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1113 struct cleanup
*old_chain
;
1114 char *gdbtk_filename
;
1116 struct sigaction action
;
1117 static sigset_t nullsigmask
= {0};
1119 old_chain
= make_cleanup (cleanup_init
, 0);
1121 /* First init tcl and tk. */
1123 interp
= Tcl_CreateInterp ();
1126 error ("Tcl_CreateInterp failed");
1128 mainWindow
= Tk_CreateMainWindow (interp
, NULL
, "gdb", "Gdb");
1131 return; /* DISPLAY probably not set */
1133 if (Tcl_Init(interp
) != TCL_OK
)
1134 error ("Tcl_Init failed: %s", interp
->result
);
1136 if (Tk_Init(interp
) != TCL_OK
)
1137 error ("Tk_Init failed: %s", interp
->result
);
1139 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
1140 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
1141 Tcl_CreateCommand (interp
, "gdb_sourcelines", call_wrapper
, gdb_sourcelines
,
1143 Tcl_CreateCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
,
1145 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
1146 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
1147 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
1148 gdb_fetch_registers
, NULL
);
1149 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
1150 gdb_changed_register_list
, NULL
);
1151 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
1152 gdb_disassemble
, NULL
);
1153 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
1154 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
1155 gdb_get_breakpoint_list
, NULL
);
1156 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
1157 gdb_get_breakpoint_info
, NULL
);
1159 command_loop_hook
= Tk_MainLoop
;
1160 print_frame_info_listing_hook
= null_routine
;
1161 query_hook
= gdbtk_query
;
1162 flush_hook
= gdbtk_flush
;
1163 create_breakpoint_hook
= gdbtk_create_breakpoint
;
1164 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
1165 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
1166 interactive_hook
= gdbtk_interactive
;
1167 target_wait_hook
= gdbtk_wait
;
1168 call_command_hook
= gdbtk_call_command
;
1170 /* Get the file descriptor for the X server */
1172 x_fd
= ConnectionNumber (Tk_Display (mainWindow
));
1174 /* Setup for I/O interrupts */
1176 action
.sa_mask
= nullsigmask
;
1177 action
.sa_flags
= 0;
1178 action
.sa_handler
= SIG_IGN
;
1179 sigaction(SIGIO
, &action
, NULL
);
1183 if (ioctl (x_fd
, FIOASYNC
, &i
))
1184 perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1188 if (ioctl (x_fd
, SIOCSPGRP
, &i
))
1189 perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1194 if (fcntl (x_fd
, F_SETOWN
, i
))
1195 perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
1196 #endif /* F_SETOWN */
1197 #endif /* !SIOCSPGRP */
1199 if (ioctl (x_fd
, I_SETSIG
, S_INPUT
|S_RDNORM
) < 0)
1200 perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1201 #endif /* ifndef FIOASYNC */
1203 add_com ("tk", class_obscure
, tk_command
,
1204 "Send a command directly into tk.");
1206 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
1209 /* Load up gdbtk.tcl after all the environment stuff has been setup. */
1211 gdbtk_filename
= getenv ("GDBTK_FILENAME");
1212 if (!gdbtk_filename
)
1213 if (access ("gdbtk.tcl", R_OK
) == 0)
1214 gdbtk_filename
= "gdbtk.tcl";
1216 gdbtk_filename
= GDBTK_FILENAME
;
1218 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
1219 prior to this point go to stdout/stderr. */
1221 fputs_unfiltered_hook
= gdbtk_fputs
;
1223 if (Tcl_EvalFile (interp
, gdbtk_filename
) != TCL_OK
)
1225 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
1227 fprintf_unfiltered (stderr
, "%s:%d: %s\n", gdbtk_filename
,
1228 interp
->errorLine
, interp
->result
);
1230 fputs_unfiltered ("Stack trace:\n", gdb_stderr
);
1231 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
1235 discard_cleanups (old_chain
);
1238 /* Come here during initialze_all_files () */
1241 _initialize_gdbtk ()
1245 /* Tell the rest of the world that Gdbtk is now set up. */
1247 init_ui_hook
= gdbtk_init
;