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
);
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 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1014 error_no_arg ("tcl command to interpret");
1016 retval
= Tcl_Eval (interp
, cmd
);
1018 result
= strdup (interp
->result
);
1020 old_chain
= make_cleanup (free
, result
);
1022 if (retval
!= TCL_OK
)
1025 printf_unfiltered ("%s\n", result
);
1027 do_cleanups (old_chain
);
1031 cleanup_init (ignored
)
1034 if (mainWindow
!= NULL
)
1035 Tk_DestroyWindow (mainWindow
);
1039 Tcl_DeleteInterp (interp
);
1043 /* Come here during long calculations to check for GUI events. Usually invoked
1044 via the QUIT macro. */
1047 gdbtk_interactive ()
1049 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1052 /* Come here when there is activity on the X file descriptor. */
1058 /* Process pending events */
1060 while (Tk_DoOneEvent (TK_DONT_WAIT
|TK_ALL_EVENTS
) != 0);
1064 gdbtk_wait (pid
, ourstatus
)
1066 struct target_waitstatus
*ourstatus
;
1068 struct sigaction action
;
1069 static sigset_t nullsigmask
= {0};
1072 /* Needed for SunOS 4.1.x */
1073 #define SA_RESTART 0
1076 action
.sa_handler
= x_event
;
1077 action
.sa_mask
= nullsigmask
;
1078 action
.sa_flags
= SA_RESTART
;
1079 sigaction(SIGIO
, &action
, NULL
);
1081 pid
= target_wait (pid
, ourstatus
);
1083 action
.sa_handler
= SIG_IGN
;
1084 sigaction(SIGIO
, &action
, NULL
);
1089 /* This is called from execute_command, and provides a wrapper around
1090 various command routines in a place where both protocol messages and
1091 user input both flow through. Mostly this is used for indicating whether
1092 the target process is running or not.
1096 gdbtk_call_command (cmdblk
, arg
, from_tty
)
1097 struct cmd_list_element
*cmdblk
;
1102 if (cmdblk
->class == class_run
)
1105 Tcl_Eval (interp
, "gdbtk_tcl_busy");
1106 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1107 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1111 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1114 /* This function is called instead of gdb's internal command loop. This is the
1115 last chance to do anything before entering the main Tk event loop. */
1120 Tcl_Eval (interp
, "gdbtk_tcl_preloop");
1127 struct cleanup
*old_chain
;
1128 char *gdbtk_filename
;
1130 struct sigaction action
;
1131 static sigset_t nullsigmask
= {0};
1133 old_chain
= make_cleanup (cleanup_init
, 0);
1135 /* First init tcl and tk. */
1137 interp
= Tcl_CreateInterp ();
1140 error ("Tcl_CreateInterp failed");
1142 mainWindow
= Tk_CreateMainWindow (interp
, NULL
, "gdb", "Gdb");
1145 return; /* DISPLAY probably not set */
1147 if (Tcl_Init(interp
) != TCL_OK
)
1148 error ("Tcl_Init failed: %s", interp
->result
);
1150 if (Tk_Init(interp
) != TCL_OK
)
1151 error ("Tk_Init failed: %s", interp
->result
);
1153 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
1154 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
1155 Tcl_CreateCommand (interp
, "gdb_sourcelines", call_wrapper
, gdb_sourcelines
,
1157 Tcl_CreateCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
,
1159 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
1160 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
1161 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
1162 gdb_fetch_registers
, NULL
);
1163 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
1164 gdb_changed_register_list
, NULL
);
1165 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
1166 gdb_disassemble
, NULL
);
1167 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
1168 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
1169 gdb_get_breakpoint_list
, NULL
);
1170 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
1171 gdb_get_breakpoint_info
, NULL
);
1173 command_loop_hook
= tk_command_loop
;
1174 print_frame_info_listing_hook
= null_routine
;
1175 query_hook
= gdbtk_query
;
1176 flush_hook
= gdbtk_flush
;
1177 create_breakpoint_hook
= gdbtk_create_breakpoint
;
1178 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
1179 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
1180 interactive_hook
= gdbtk_interactive
;
1181 target_wait_hook
= gdbtk_wait
;
1182 call_command_hook
= gdbtk_call_command
;
1184 /* Get the file descriptor for the X server */
1186 x_fd
= ConnectionNumber (Tk_Display (mainWindow
));
1188 /* Setup for I/O interrupts */
1190 action
.sa_mask
= nullsigmask
;
1191 action
.sa_flags
= 0;
1192 action
.sa_handler
= SIG_IGN
;
1193 sigaction(SIGIO
, &action
, NULL
);
1197 if (ioctl (x_fd
, FIOASYNC
, &i
))
1198 perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1202 if (ioctl (x_fd
, SIOCSPGRP
, &i
))
1203 perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1208 if (fcntl (x_fd
, F_SETOWN
, i
))
1209 perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
1210 #endif /* F_SETOWN */
1211 #endif /* !SIOCSPGRP */
1213 if (ioctl (x_fd
, I_SETSIG
, S_INPUT
|S_RDNORM
) < 0)
1214 perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1215 #endif /* ifndef FIOASYNC */
1217 add_com ("tk", class_obscure
, tk_command
,
1218 "Send a command directly into tk.");
1220 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
1223 /* Load up gdbtk.tcl after all the environment stuff has been setup. */
1225 gdbtk_filename
= getenv ("GDBTK_FILENAME");
1226 if (!gdbtk_filename
)
1227 if (access ("gdbtk.tcl", R_OK
) == 0)
1228 gdbtk_filename
= "gdbtk.tcl";
1230 gdbtk_filename
= GDBTK_FILENAME
;
1232 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
1233 prior to this point go to stdout/stderr. */
1235 fputs_unfiltered_hook
= gdbtk_fputs
;
1237 if (Tcl_EvalFile (interp
, gdbtk_filename
) != TCL_OK
)
1239 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
1241 fprintf_unfiltered (stderr
, "%s:%d: %s\n", gdbtk_filename
,
1242 interp
->errorLine
, interp
->result
);
1244 fputs_unfiltered ("Stack trace:\n", gdb_stderr
);
1245 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
1249 discard_cleanups (old_chain
);
1252 /* Come here during initialize_all_files () */
1255 _initialize_gdbtk ()
1259 /* Tell the rest of the world that Gdbtk is now set up. */
1261 init_ui_hook
= gdbtk_init
;