1 /* Tcl/Tk interface routines.
2 Copyright 1994, 1995 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., 675 Mass Ave, Cambridge, MA 02139, USA. */
32 #ifdef ANSI_PROTOTYPES
42 #include <sys/ioctl.h>
49 #include <sys/stropts.h>
52 /* Handle for TCL interpreter */
53 static Tcl_Interp
*interp
= NULL
;
55 /* Handle for TK main window */
56 static Tk_Window mainWindow
= NULL
;
58 static int x_fd
; /* X network socket */
60 /* This variable determines where memory used for disassembly is read from.
62 If > 0, then disassembly comes from the exec file rather than the target
63 (which might be at the other end of a slow serial link). If == 0 then
64 disassembly comes from target. If < 0 disassembly is automatically switched
65 to the target if it's an inferior process, otherwise the exec file is
69 static int disassemble_from_exec
= -1;
77 /* The following routines deal with stdout/stderr data, which is created by
78 {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the
79 lowest level of these routines and capture all output from the rest of GDB.
80 Normally they present their data to tcl via callbacks to the following tcl
81 routines: gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush. These
82 in turn call tk routines to update the display.
84 Under some circumstances, you may want to collect the output so that it can
85 be returned as the value of a tcl procedure. This can be done by
86 surrounding the output routines with calls to start_saving_output and
87 finish_saving_output. The saved data can then be retrieved with
88 get_saved_output (but this must be done before the call to
89 finish_saving_output). */
91 /* Dynamic string header for stdout. */
93 static Tcl_DString
*result_ptr
;
100 /* Force immediate screen update */
102 Tcl_VarEval (interp
, "gdbtk_tcl_flush", NULL
);
107 gdbtk_fputs (ptr
, stream
)
112 Tcl_DStringAppend (result_ptr
, (char *)ptr
, -1);
117 Tcl_DStringInit (&str
);
119 Tcl_DStringAppend (&str
, "gdbtk_tcl_fputs", -1);
120 Tcl_DStringAppendElement (&str
, (char *)ptr
);
122 Tcl_Eval (interp
, Tcl_DStringValue (&str
));
123 Tcl_DStringFree (&str
);
128 gdbtk_query (query
, args
)
135 vsprintf (buf
, query
, args
);
136 Tcl_VarEval (interp
, "gdbtk_tcl_query ", "{", buf
, "}", NULL
);
138 val
= atol (interp
->result
);
143 #ifdef ANSI_PROTOTYPES
144 dsprintf_append_element (Tcl_DString
*dsp
, char *format
, ...)
146 dsprintf_append_element (va_alist
)
153 #ifdef ANSI_PROTOTYPES
154 va_start (args
, format
);
160 dsp
= va_arg (args
, Tcl_DString
*);
161 format
= va_arg (args
, char *);
164 vsprintf (buf
, format
, args
);
166 Tcl_DStringAppendElement (dsp
, buf
);
170 gdb_get_breakpoint_list (clientData
, interp
, argc
, argv
)
171 ClientData clientData
;
176 struct breakpoint
*b
;
177 extern struct breakpoint
*breakpoint_chain
;
180 error ("wrong # args");
182 for (b
= breakpoint_chain
; b
; b
= b
->next
)
183 if (b
->type
== bp_breakpoint
)
184 dsprintf_append_element (result_ptr
, "%d", b
->number
);
190 gdb_get_breakpoint_info (clientData
, interp
, argc
, argv
)
191 ClientData clientData
;
196 struct symtab_and_line sal
;
197 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
198 "finish", "watchpoint", "hardware watchpoint",
199 "read watchpoint", "access watchpoint",
200 "longjmp", "longjmp resume", "step resume",
201 "through sigtramp", "watchpoint scope",
203 static char *bpdisp
[] = {"delete", "disable", "donttouch"};
204 struct command_line
*cmd
;
206 struct breakpoint
*b
;
207 extern struct breakpoint
*breakpoint_chain
;
210 error ("wrong # args");
212 bpnum
= atoi (argv
[1]);
214 for (b
= breakpoint_chain
; b
; b
= b
->next
)
215 if (b
->number
== bpnum
)
218 if (!b
|| b
->type
!= bp_breakpoint
)
219 error ("Breakpoint #%d does not exist", bpnum
);
221 sal
= find_pc_line (b
->address
, 0);
223 Tcl_DStringAppendElement (result_ptr
, symtab_to_filename (sal
.symtab
));
224 dsprintf_append_element (result_ptr
, "%d", sal
.line
);
225 dsprintf_append_element (result_ptr
, "0x%lx", b
->address
);
226 Tcl_DStringAppendElement (result_ptr
, bptypes
[b
->type
]);
227 Tcl_DStringAppendElement (result_ptr
, b
->enable
== enabled
? "1" : "0");
228 Tcl_DStringAppendElement (result_ptr
, bpdisp
[b
->disposition
]);
229 dsprintf_append_element (result_ptr
, "%d", b
->silent
);
230 dsprintf_append_element (result_ptr
, "%d", b
->ignore_count
);
232 Tcl_DStringStartSublist (result_ptr
);
233 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
234 Tcl_DStringAppendElement (result_ptr
, cmd
->line
);
235 Tcl_DStringEndSublist (result_ptr
);
237 Tcl_DStringAppendElement (result_ptr
, b
->cond_string
);
239 dsprintf_append_element (result_ptr
, "%d", b
->thread
);
240 dsprintf_append_element (result_ptr
, "%d", b
->hit_count
);
246 breakpoint_notify(b
, action
)
247 struct breakpoint
*b
;
253 if (b
->type
!= bp_breakpoint
)
256 sprintf (buf
, "gdbtk_tcl_breakpoint %s %d", action
, b
->number
);
258 v
= Tcl_Eval (interp
, buf
);
262 gdbtk_fputs (interp
->result
, gdb_stdout
);
263 gdbtk_fputs ("\n", gdb_stdout
);
268 gdbtk_create_breakpoint(b
)
269 struct breakpoint
*b
;
271 breakpoint_notify (b
, "create");
275 gdbtk_delete_breakpoint(b
)
276 struct breakpoint
*b
;
278 breakpoint_notify (b
, "delete");
282 gdbtk_modify_breakpoint(b
)
283 struct breakpoint
*b
;
285 breakpoint_notify (b
, "modify");
288 /* This implements the TCL command `gdb_loc', which returns a list consisting
289 of the source and line number associated with the current pc. */
292 gdb_loc (clientData
, interp
, argc
, argv
)
293 ClientData clientData
;
299 struct symtab_and_line sal
;
305 pc
= selected_frame
? selected_frame
->pc
: stop_pc
;
306 sal
= find_pc_line (pc
, 0);
310 struct symtabs_and_lines sals
;
313 sals
= decode_line_spec (argv
[1], 1);
320 error ("Ambiguous line spec");
325 error ("wrong # args");
328 Tcl_DStringAppendElement (result_ptr
, sal
.symtab
->filename
);
330 Tcl_DStringAppendElement (result_ptr
, "");
332 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
333 Tcl_DStringAppendElement (result_ptr
, funcname
);
335 filename
= symtab_to_filename (sal
.symtab
);
336 Tcl_DStringAppendElement (result_ptr
, filename
);
338 dsprintf_append_element (result_ptr
, "%d", sal
.line
); /* line number */
340 dsprintf_append_element (result_ptr
, "0x%lx", pc
); /* PC */
345 /* This implements the TCL command `gdb_eval'. */
348 gdb_eval (clientData
, interp
, argc
, argv
)
349 ClientData clientData
;
354 struct expression
*expr
;
355 struct cleanup
*old_chain
;
359 error ("wrong # args");
361 expr
= parse_expression (argv
[1]);
363 old_chain
= make_cleanup (free_current_contents
, &expr
);
365 val
= evaluate_expression (expr
);
367 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
368 gdb_stdout
, 0, 0, 0, 0);
370 do_cleanups (old_chain
);
375 /* This implements the TCL command `gdb_sourcelines', which returns a list of
376 all of the lines containing executable code for the specified source file
377 (ie: lines where you can put breakpoints). */
380 gdb_sourcelines (clientData
, interp
, argc
, argv
)
381 ClientData clientData
;
386 struct symtab
*symtab
;
387 struct linetable_entry
*le
;
391 error ("wrong # args");
393 symtab
= lookup_symtab (argv
[1]);
396 error ("No such file");
398 /* If there's no linetable, or no entries, then we are done. */
400 if (!symtab
->linetable
401 || symtab
->linetable
->nitems
== 0)
403 Tcl_DStringAppendElement (result_ptr
, "");
407 le
= symtab
->linetable
->item
;
408 nlines
= symtab
->linetable
->nitems
;
410 for (;nlines
> 0; nlines
--, le
++)
412 /* If the pc of this line is the same as the pc of the next line, then
415 && le
->pc
== (le
+ 1)->pc
)
418 dsprintf_append_element (result_ptr
, "%d", le
->line
);
425 map_arg_registers (argc
, argv
, func
, argp
)
428 void (*func
) PARAMS ((int regnum
, void *argp
));
433 /* Note that the test for a valid register must include checking the
434 reg_names array because NUM_REGS may be allocated for the union of the
435 register sets within a family of related processors. In this case, the
436 trailing entries of reg_names will change depending upon the particular
437 processor being debugged. */
439 if (argc
== 0) /* No args, just do all the regs */
443 && reg_names
[regnum
] != NULL
444 && *reg_names
[regnum
] != '\000';
451 /* Else, list of register #s, just do listed regs */
452 for (; argc
> 0; argc
--, argv
++)
454 regnum
= atoi (*argv
);
458 && reg_names
[regnum
] != NULL
459 && *reg_names
[regnum
] != '\000')
462 error ("bad register number");
469 get_register_name (regnum
, argp
)
471 void *argp
; /* Ignored */
473 Tcl_DStringAppendElement (result_ptr
, reg_names
[regnum
]);
476 /* This implements the TCL command `gdb_regnames', which returns a list of
477 all of the register names. */
480 gdb_regnames (clientData
, interp
, argc
, argv
)
481 ClientData clientData
;
489 return map_arg_registers (argc
, argv
, get_register_name
, 0);
492 #ifndef REGISTER_CONVERTIBLE
493 #define REGISTER_CONVERTIBLE(x) (0 != 0)
496 #ifndef REGISTER_CONVERT_TO_VIRTUAL
497 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
500 #ifndef INVALID_FLOAT
501 #define INVALID_FLOAT(x, y) (0 != 0)
505 get_register (regnum
, fp
)
509 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
510 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
511 int format
= (int)fp
;
513 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
515 Tcl_DStringAppendElement (result_ptr
, "Optimized out");
519 /* Convert raw data to virtual format if necessary. */
521 if (REGISTER_CONVERTIBLE (regnum
))
523 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
524 raw_buffer
, virtual_buffer
);
527 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
529 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
530 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
532 Tcl_DStringAppend (result_ptr
, " ", -1);
536 gdb_fetch_registers (clientData
, interp
, argc
, argv
)
537 ClientData clientData
;
545 error ("wrong # args");
553 return map_arg_registers (argc
, argv
, get_register
, format
);
556 /* This contains the previous values of the registers, since the last call to
557 gdb_changed_register_list. */
559 static char old_regs
[REGISTER_BYTES
];
562 register_changed_p (regnum
, argp
)
564 void *argp
; /* Ignored */
566 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
569 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
572 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
573 REGISTER_RAW_SIZE (regnum
)) == 0)
576 /* Found a changed register. Save new value and return it's number. */
578 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
579 REGISTER_RAW_SIZE (regnum
));
581 dsprintf_append_element (result_ptr
, "%d", regnum
);
585 gdb_changed_register_list (clientData
, interp
, argc
, argv
)
586 ClientData clientData
;
594 return map_arg_registers (argc
, argv
, register_changed_p
, NULL
);
597 /* This implements the TCL command `gdb_cmd', which sends it's argument into
598 the GDB command scanner. */
601 gdb_cmd (clientData
, interp
, argc
, argv
)
602 ClientData clientData
;
608 error ("wrong # args");
610 execute_command (argv
[1], 1);
612 bpstat_do_actions (&stop_bpstat
);
617 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
618 handles cleanups, and calls to return_to_top_level (usually via error).
619 This is necessary in order to prevent a longjmp out of the bowels of Tk,
620 possibly leaving things in a bad state. Since this routine can be called
621 recursively, it needs to save and restore the contents of the jmp_buf as
625 call_wrapper (clientData
, interp
, argc
, argv
)
626 ClientData clientData
;
632 struct cleanup
*saved_cleanup_chain
;
634 jmp_buf saved_error_return
;
635 Tcl_DString result
, *old_result_ptr
;
637 Tcl_DStringInit (&result
);
638 old_result_ptr
= result_ptr
;
639 result_ptr
= &result
;
641 func
= (Tcl_CmdProc
*)clientData
;
642 memcpy (saved_error_return
, error_return
, sizeof (jmp_buf));
644 saved_cleanup_chain
= save_cleanups ();
646 if (!setjmp (error_return
))
647 val
= func (clientData
, interp
, argc
, argv
);
650 val
= TCL_ERROR
; /* Flag an error for TCL */
652 gdb_flush (gdb_stderr
); /* Flush error output */
654 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
656 /* In case of an error, we may need to force the GUI into idle mode because
657 gdbtk_call_command may have bombed out while in the command routine. */
659 Tcl_VarEval (interp
, "gdbtk_tcl_idle", NULL
);
662 do_cleanups (ALL_CLEANUPS
);
664 restore_cleanups (saved_cleanup_chain
);
666 memcpy (error_return
, saved_error_return
, sizeof (jmp_buf));
668 Tcl_DStringResult (interp
, &result
);
669 result_ptr
= old_result_ptr
;
675 gdb_listfiles (clientData
, interp
, argc
, argv
)
676 ClientData clientData
;
681 struct objfile
*objfile
;
682 struct partial_symtab
*psymtab
;
683 struct symtab
*symtab
;
685 ALL_PSYMTABS (objfile
, psymtab
)
686 Tcl_DStringAppendElement (result_ptr
, psymtab
->filename
);
688 ALL_SYMTABS (objfile
, symtab
)
689 Tcl_DStringAppendElement (result_ptr
, symtab
->filename
);
695 gdb_stop (clientData
, interp
, argc
, argv
)
696 ClientData clientData
;
706 /* This implements the TCL command `gdb_disassemble'. */
709 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
713 disassemble_info
*info
;
715 extern struct target_ops exec_ops
;
719 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
730 /* We need a different sort of line table from the normal one cuz we can't
731 depend upon implicit line-end pc's for lines. This is because of the
732 reordering we are about to do. */
734 struct my_line_entry
{
741 compare_lines (mle1p
, mle2p
)
745 struct my_line_entry
*mle1
, *mle2
;
748 mle1
= (struct my_line_entry
*) mle1p
;
749 mle2
= (struct my_line_entry
*) mle2p
;
751 val
= mle1
->line
- mle2
->line
;
756 return mle1
->start_pc
- mle2
->start_pc
;
760 gdb_disassemble (clientData
, interp
, argc
, argv
)
761 ClientData clientData
;
766 CORE_ADDR pc
, low
, high
;
767 int mixed_source_and_assembly
;
768 static disassemble_info di
= {
769 (fprintf_ftype
) fprintf_filtered
, /* fprintf_func */
770 gdb_stdout
, /* stream */
771 NULL
, /* application_data */
773 NULL
, /* private_data */
774 NULL
, /* read_memory_func */
775 dis_asm_memory_error
, /* memory_error_func */
776 dis_asm_print_address
/* print_address_func */
779 if (argc
!= 3 && argc
!= 4)
780 error ("wrong # args");
782 if (strcmp (argv
[1], "source") == 0)
783 mixed_source_and_assembly
= 1;
784 else if (strcmp (argv
[1], "nosource") == 0)
785 mixed_source_and_assembly
= 0;
787 error ("First arg must be 'source' or 'nosource'");
789 low
= parse_and_eval_address (argv
[2]);
793 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
794 error ("No function contains specified address");
797 high
= parse_and_eval_address (argv
[3]);
799 /* If disassemble_from_exec == -1, then we use the following heuristic to
800 determine whether or not to do disassembly from target memory or from the
803 If we're debugging a local process, read target memory, instead of the
804 exec file. This makes disassembly of functions in shared libs work
807 Else, we're debugging a remote process, and should disassemble from the
808 exec file for speed. However, this is no good if the target modifies it's
809 code (for relocation, or whatever).
812 if (disassemble_from_exec
== -1)
813 if (strcmp (target_shortname
, "child") == 0
814 || strcmp (target_shortname
, "procfs") == 0
815 || strcmp (target_shortname
, "vxprocess") == 0)
816 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
818 disassemble_from_exec
= 1; /* It's remote, read the exec file */
820 if (disassemble_from_exec
)
821 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
823 di
.read_memory_func
= dis_asm_read_memory
;
825 /* If just doing straight assembly, all we need to do is disassemble
826 everything between low and high. If doing mixed source/assembly, we've
827 got a totally different path to follow. */
829 if (mixed_source_and_assembly
)
830 { /* Come here for mixed source/assembly */
831 /* The idea here is to present a source-O-centric view of a function to
832 the user. This means that things are presented in source order, with
833 (possibly) out of order assembly immediately following. */
834 struct symtab
*symtab
;
835 struct linetable_entry
*le
;
838 struct my_line_entry
*mle
;
839 struct symtab_and_line sal
;
844 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
849 /* First, convert the linetable to a bunch of my_line_entry's. */
851 le
= symtab
->linetable
->item
;
852 nlines
= symtab
->linetable
->nitems
;
857 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
861 /* Copy linetable entries for this function into our data structure, creating
862 end_pc's and setting out_of_order as appropriate. */
864 /* First, skip all the preceding functions. */
866 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
868 /* Now, copy all entries before the end of this function. */
871 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
873 if (le
[i
].line
== le
[i
+ 1].line
874 && le
[i
].pc
== le
[i
+ 1].pc
)
875 continue; /* Ignore duplicates */
877 mle
[newlines
].line
= le
[i
].line
;
878 if (le
[i
].line
> le
[i
+ 1].line
)
880 mle
[newlines
].start_pc
= le
[i
].pc
;
881 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
885 /* If we're on the last line, and it's part of the function, then we need to
886 get the end pc in a special way. */
891 mle
[newlines
].line
= le
[i
].line
;
892 mle
[newlines
].start_pc
= le
[i
].pc
;
893 sal
= find_pc_line (le
[i
].pc
, 0);
894 mle
[newlines
].end_pc
= sal
.end
;
898 /* Now, sort mle by line #s (and, then by addresses within lines). */
901 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
903 /* Now, for each line entry, emit the specified lines (unless they have been
904 emitted before), followed by the assembly code for that line. */
906 next_line
= 0; /* Force out first line */
907 for (i
= 0; i
< newlines
; i
++)
909 /* Print out everything from next_line to the current line. */
911 if (mle
[i
].line
>= next_line
)
914 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
916 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
918 next_line
= mle
[i
].line
+ 1;
921 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
924 fputs_unfiltered (" ", gdb_stdout
);
925 print_address (pc
, gdb_stdout
);
926 fputs_unfiltered (":\t ", gdb_stdout
);
927 pc
+= (*tm_print_insn
) (pc
, &di
);
928 fputs_unfiltered ("\n", gdb_stdout
);
935 for (pc
= low
; pc
< high
; )
938 fputs_unfiltered (" ", gdb_stdout
);
939 print_address (pc
, gdb_stdout
);
940 fputs_unfiltered (":\t ", gdb_stdout
);
941 pc
+= (*tm_print_insn
) (pc
, &di
);
942 fputs_unfiltered ("\n", gdb_stdout
);
946 gdb_flush (gdb_stdout
);
952 tk_command (cmd
, from_tty
)
958 struct cleanup
*old_chain
;
960 retval
= Tcl_Eval (interp
, cmd
);
962 result
= strdup (interp
->result
);
964 old_chain
= make_cleanup (free
, result
);
966 if (retval
!= TCL_OK
)
969 printf_unfiltered ("%s\n", result
);
971 do_cleanups (old_chain
);
975 cleanup_init (ignored
)
978 if (mainWindow
!= NULL
)
979 Tk_DestroyWindow (mainWindow
);
983 Tcl_DeleteInterp (interp
);
987 /* Come here during long calculations to check for GUI events. Usually invoked
988 via the QUIT macro. */
993 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
996 /* Come here when there is activity on the X file descriptor. */
1002 /* Process pending events */
1004 while (Tk_DoOneEvent (TK_DONT_WAIT
|TK_ALL_EVENTS
) != 0);
1008 gdbtk_wait (pid
, ourstatus
)
1010 struct target_waitstatus
*ourstatus
;
1012 struct sigaction action
;
1013 static sigset_t nullsigmask
= {0};
1016 /* Needed for SunOS 4.1.x */
1017 #define SA_RESTART 0
1020 action
.sa_handler
= x_event
;
1021 action
.sa_mask
= nullsigmask
;
1022 action
.sa_flags
= SA_RESTART
;
1023 sigaction(SIGIO
, &action
, NULL
);
1025 pid
= target_wait (pid
, ourstatus
);
1027 action
.sa_handler
= SIG_IGN
;
1028 sigaction(SIGIO
, &action
, NULL
);
1033 /* This is called from execute_command, and provides a wrapper around
1034 various command routines in a place where both protocol messages and
1035 user input both flow through. Mostly this is used for indicating whether
1036 the target process is running or not.
1040 gdbtk_call_command (cmdblk
, arg
, from_tty
)
1041 struct cmd_list_element
*cmdblk
;
1045 if (cmdblk
->class == class_run
)
1047 Tcl_VarEval (interp
, "gdbtk_tcl_busy", NULL
);
1048 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1049 Tcl_VarEval (interp
, "gdbtk_tcl_idle", NULL
);
1052 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
1058 struct cleanup
*old_chain
;
1059 char *gdbtk_filename
;
1061 struct sigaction action
;
1062 static sigset_t nullsigmask
= {0};
1064 old_chain
= make_cleanup (cleanup_init
, 0);
1066 /* First init tcl and tk. */
1068 interp
= Tcl_CreateInterp ();
1071 error ("Tcl_CreateInterp failed");
1073 mainWindow
= Tk_CreateMainWindow (interp
, NULL
, "gdb", "Gdb");
1076 return; /* DISPLAY probably not set */
1078 if (Tcl_Init(interp
) != TCL_OK
)
1079 error ("Tcl_Init failed: %s", interp
->result
);
1081 if (Tk_Init(interp
) != TCL_OK
)
1082 error ("Tk_Init failed: %s", interp
->result
);
1084 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
1085 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
1086 Tcl_CreateCommand (interp
, "gdb_sourcelines", call_wrapper
, gdb_sourcelines
,
1088 Tcl_CreateCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
,
1090 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
1091 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
1092 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
1093 gdb_fetch_registers
, NULL
);
1094 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
1095 gdb_changed_register_list
, NULL
);
1096 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
1097 gdb_disassemble
, NULL
);
1098 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
1099 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
1100 gdb_get_breakpoint_list
, NULL
);
1101 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
1102 gdb_get_breakpoint_info
, NULL
);
1104 command_loop_hook
= Tk_MainLoop
;
1105 print_frame_info_listing_hook
= null_routine
;
1106 query_hook
= gdbtk_query
;
1107 flush_hook
= gdbtk_flush
;
1108 create_breakpoint_hook
= gdbtk_create_breakpoint
;
1109 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
1110 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
1111 interactive_hook
= gdbtk_interactive
;
1112 target_wait_hook
= gdbtk_wait
;
1113 call_command_hook
= gdbtk_call_command
;
1115 /* Get the file descriptor for the X server */
1117 x_fd
= ConnectionNumber (Tk_Display (mainWindow
));
1119 /* Setup for I/O interrupts */
1121 action
.sa_mask
= nullsigmask
;
1122 action
.sa_flags
= 0;
1123 action
.sa_handler
= SIG_IGN
;
1124 sigaction(SIGIO
, &action
, NULL
);
1128 if (ioctl (x_fd
, FIOASYNC
, &i
))
1129 perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
1133 if (ioctl (x_fd
, SIOCSPGRP
, &i
))
1134 perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
1139 if (fcntl (x_fd
, F_SETOWN
, i
))
1140 perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
1141 #endif /* F_SETOWN */
1142 #endif /* !SIOCSPGRP */
1144 if (ioctl (x_fd
, I_SETSIG
, S_INPUT
|S_RDNORM
) < 0)
1145 perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
1146 #endif /* ifndef FIOASYNC */
1148 add_com ("tk", class_obscure
, tk_command
,
1149 "Send a command directly into tk.");
1151 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
1154 /* Load up gdbtk.tcl after all the environment stuff has been setup. */
1156 gdbtk_filename
= getenv ("GDBTK_FILENAME");
1157 if (!gdbtk_filename
)
1158 if (access ("gdbtk.tcl", R_OK
) == 0)
1159 gdbtk_filename
= "gdbtk.tcl";
1161 gdbtk_filename
= GDBTK_FILENAME
;
1163 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
1164 prior to this point go to stdout/stderr. */
1166 fputs_unfiltered_hook
= gdbtk_fputs
;
1168 if (Tcl_EvalFile (interp
, gdbtk_filename
) != TCL_OK
)
1170 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
1172 fprintf_unfiltered (stderr
, "%s:%d: %s\n", gdbtk_filename
,
1173 interp
->errorLine
, interp
->result
);
1175 fputs_unfiltered ("Stack trace:\n", gdb_stderr
);
1176 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
1180 discard_cleanups (old_chain
);
1183 /* Come here during initialze_all_files () */
1186 _initialize_gdbtk ()
1190 /* Tell the rest of the world that Gdbtk is now set up. */
1192 init_ui_hook
= gdbtk_init
;