1 /* Tcl/Tk interface routines.
2 Copyright 1994, 1995, 1996, 1997, 1998 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. */
31 #include "tracepoint.h"
47 /* start-sanitize-ide */
51 /* end-sanitize-ide */
54 #ifdef ANSI_PROTOTYPES
64 #include <sys/ioctl.h>
65 #include "gdb_string.h"
74 #define GDBTK_PATH_SEP ";"
76 #define GDBTK_PATH_SEP ":"
79 /* Some versions (1.3.79, 1.3.81) of Linux don't support SIOCSPGRP the way
80 gdbtk wants to use it... */
85 extern int Tktable_Init
PARAMS ((Tcl_Interp
*interp
));
87 static int No_Update
= 0;
88 static int load_in_progress
= 0;
89 static int in_fputs
= 0;
91 int gdbtk_load_hash
PARAMS ((char *, unsigned long));
92 int (*ui_load_progress_hook
) PARAMS ((char *, unsigned long));
93 void (*pre_add_symbol_hook
) PARAMS ((char *));
94 void (*post_add_symbol_hook
) PARAMS ((void));
97 extern void (*ui_loop_hook
) PARAMS ((int));
100 char * get_prompt
PARAMS ((void));
102 static void null_routine
PARAMS ((int));
103 static void gdbtk_flush
PARAMS ((FILE *));
104 static void gdbtk_fputs
PARAMS ((const char *, FILE *));
105 static int gdbtk_query
PARAMS ((const char *, va_list));
106 static void gdbtk_warning
PARAMS ((const char *, va_list));
107 static void gdbtk_ignorable_warning
PARAMS ((const char *));
108 static char *gdbtk_readline
PARAMS ((char *));
109 static void gdbtk_init
PARAMS ((char *));
110 static void tk_command_loop
PARAMS ((void));
111 static void gdbtk_call_command
PARAMS ((struct cmd_list_element
*, char *, int));
112 static int gdbtk_wait
PARAMS ((int, struct target_waitstatus
*));
113 static void x_event
PARAMS ((int));
114 static void gdbtk_interactive
PARAMS ((void));
115 static void cleanup_init
PARAMS ((int));
116 static void tk_command
PARAMS ((char *, int));
117 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
118 static int compare_lines
PARAMS ((const PTR
, const PTR
));
119 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
120 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
121 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
122 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
123 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
124 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
125 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
126 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
127 static int call_obj_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
128 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
129 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
130 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
131 static void gdbtk_readline_end
PARAMS ((void));
132 static void pc_changed
PARAMS ((void));
133 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
134 static void register_changed_p
PARAMS ((int, void *));
135 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
136 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
137 static void breakpoint_notify
PARAMS ((struct breakpoint
*, const char *));
138 static void gdbtk_create_breakpoint
PARAMS ((struct breakpoint
*));
139 static void gdbtk_delete_breakpoint
PARAMS ((struct breakpoint
*));
140 static void gdbtk_modify_breakpoint
PARAMS ((struct breakpoint
*));
141 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
142 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
143 static int map_arg_registers
PARAMS ((int, char *[], void (*) (int, void *), void *));
144 static void get_register_name
PARAMS ((int, void *));
145 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
146 static void get_register
PARAMS ((int, void *));
147 static int gdb_trace_status
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
148 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*, int, char *argv
[]));
149 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
150 void TclDebug
PARAMS ((const char *fmt
, ...));
151 static int gdb_get_locals_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
153 static int gdb_get_args_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
155 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
156 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
157 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
158 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
159 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
160 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
161 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
162 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
163 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
164 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
165 static void gdbtk_create_tracepoint
PARAMS ((struct tracepoint
*));
166 static void gdbtk_delete_tracepoint
PARAMS ((struct tracepoint
*));
167 static void gdbtk_modify_tracepoint
PARAMS ((struct tracepoint
*));
168 static void tracepoint_notify
PARAMS ((struct tracepoint
*, const char *));
169 static void gdbtk_print_frame_info
PARAMS ((struct symtab
*, int, int, int));
170 void gdbtk_pre_add_symbol
PARAMS ((char *));
171 void gdbtk_post_add_symbol
PARAMS ((void));
172 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
173 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
174 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
175 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
176 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, char *[]));
177 static int gdb_get_trace_frame_num
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
179 /* Handle for TCL interpreter */
180 static Tcl_Interp
*interp
= NULL
;
182 static int gdbtk_timer_going
= 0;
183 static void gdbtk_start_timer
PARAMS ((void));
184 static void gdbtk_stop_timer
PARAMS ((void));
186 /* This variable is true when the inferior is running. Although it's
187 possible to disable most input from widgets and thus prevent
188 attempts to do anything while the inferior is running, any commands
189 that get through - even a simple memory read - are Very Bad, and
190 may cause GDB to crash or behave strangely. So, this variable
191 provides an extra layer of defense. */
193 static int running_now
;
195 /* This variable determines where memory used for disassembly is read from.
196 If > 0, then disassembly comes from the exec file rather than the
197 target (which might be at the other end of a slow serial link). If
198 == 0 then disassembly comes from target. If < 0 disassembly is
199 automatically switched to the target if it's an inferior process,
200 otherwise the exec file is used. */
202 static int disassemble_from_exec
= -1;
206 /* Supply malloc calls for tcl/tk. We do not want to do this on
207 Windows, because Tcl_Alloc is probably in a DLL which will not call
208 the mmalloc routines. */
214 return xmalloc (size
);
218 Tcl_Realloc (ptr
, size
)
222 return xrealloc (ptr
, size
);
232 #endif /* ! _WIN32 */
242 /* On Windows, if we hold a file open, other programs can't write to
243 it. In particular, we don't want to hold the executable open,
244 because it will mean that people have to get out of the debugging
245 session in order to remake their program. So we close it, although
246 this will cost us if and when we need to reopen it. */
256 bfd_cache_close (o
->obfd
);
259 if (exec_bfd
!= NULL
)
260 bfd_cache_close (exec_bfd
);
265 /* The following routines deal with stdout/stderr data, which is created by
266 {f}printf_{un}filtered and friends. gdbtk_fputs and gdbtk_flush are the
267 lowest level of these routines and capture all output from the rest of GDB.
268 Normally they present their data to tcl via callbacks to the following tcl
269 routines: gdbtk_tcl_fputs, gdbtk_tcl_fputs_error, and gdbtk_flush. These
270 in turn call tk routines to update the display.
272 Under some circumstances, you may want to collect the output so that it can
273 be returned as the value of a tcl procedure. This can be done by
274 surrounding the output routines with calls to start_saving_output and
275 finish_saving_output. The saved data can then be retrieved with
276 get_saved_output (but this must be done before the call to
277 finish_saving_output). */
279 /* Dynamic string for output. */
281 static Tcl_DString
*result_ptr
;
283 /* Dynamic string for stderr. This is only used if result_ptr is
286 static Tcl_DString
*error_string_ptr
;
293 /* Force immediate screen update */
295 Tcl_VarEval (interp
, "gdbtk_tcl_flush", NULL
);
299 /* Print the string PTR, with necessary hair for dealing with the
300 GDB console thingy, etc. To wit:
302 Append the string PTR to result_ptr or error_string_ptr, if they
303 are set. Otherwise, call the Tcl function `gdbtk_tcl_fputs', with
304 the string PTR as its only argument. */
306 gdbtk_fputs (ptr
, stream
)
310 char *merge
[2], *command
;
314 Tcl_DStringAppend (result_ptr
, (char *) ptr
, -1);
315 else if (error_string_ptr
!= NULL
&& stream
== gdb_stderr
)
316 Tcl_DStringAppend (error_string_ptr
, (char *) ptr
, -1);
319 merge
[0] = "gdbtk_tcl_fputs";
320 merge
[1] = (char *)ptr
;
321 command
= Tcl_Merge (2, merge
);
322 Tcl_Eval (interp
, command
);
329 gdbtk_warning (warning
, args
)
333 char buf
[200], *merge
[2];
336 vsprintf (buf
, warning
, args
);
337 merge
[0] = "gdbtk_tcl_warning";
339 command
= Tcl_Merge (2, merge
);
340 Tcl_Eval (interp
, command
);
345 gdbtk_ignorable_warning (warning
)
348 char buf
[200], *merge
[2];
351 sprintf (buf
, warning
);
352 merge
[0] = "gdbtk_tcl_ignorable_warning";
354 command
= Tcl_Merge (2, merge
);
355 Tcl_Eval (interp
, command
);
360 gdbtk_query (query
, args
)
364 char buf
[200], *merge
[2];
368 vsprintf (buf
, query
, args
);
369 merge
[0] = "gdbtk_tcl_query";
371 command
= Tcl_Merge (2, merge
);
372 Tcl_Eval (interp
, command
);
375 val
= atol (interp
->result
);
381 #ifdef ANSI_PROTOTYPES
382 gdbtk_readline_begin (char *format
, ...)
384 gdbtk_readline_begin (va_alist
)
389 char buf
[200], *merge
[2];
392 #ifdef ANSI_PROTOTYPES
393 va_start (args
, format
);
397 format
= va_arg (args
, char *);
400 vsprintf (buf
, format
, args
);
401 merge
[0] = "gdbtk_tcl_readline_begin";
403 command
= Tcl_Merge (2, merge
);
404 Tcl_Eval (interp
, command
);
409 gdbtk_readline (prompt
)
420 merge
[0] = "gdbtk_tcl_readline";
422 command
= Tcl_Merge (2, merge
);
423 result
= Tcl_Eval (interp
, command
);
425 if (result
== TCL_OK
)
427 return (strdup (interp
-> result
));
431 gdbtk_fputs (interp
-> result
, gdb_stdout
);
432 gdbtk_fputs ("\n", gdb_stdout
);
438 gdbtk_readline_end ()
440 Tcl_Eval (interp
, "gdbtk_tcl_readline_end");
446 Tcl_Eval (interp
, "gdbtk_pc_changed");
451 #ifdef ANSI_PROTOTYPES
452 dsprintf_append_element (Tcl_DString
*dsp
, char *format
, ...)
454 dsprintf_append_element (va_alist
)
461 #ifdef ANSI_PROTOTYPES
462 va_start (args
, format
);
468 dsp
= va_arg (args
, Tcl_DString
*);
469 format
= va_arg (args
, char *);
472 vsprintf (buf
, format
, args
);
474 Tcl_DStringAppendElement (dsp
, buf
);
478 gdb_path_conv (clientData
, interp
, argc
, argv
)
479 ClientData clientData
;
485 char pathname
[256], *ptr
;
487 error ("wrong # args");
488 cygwin32_conv_to_full_win32_path (argv
[1], pathname
);
489 for (ptr
= pathname
; *ptr
; ptr
++)
495 char *pathname
= argv
[1];
497 Tcl_DStringAppend (result_ptr
, pathname
, strlen(pathname
));
502 gdb_get_breakpoint_list (clientData
, interp
, argc
, argv
)
503 ClientData clientData
;
508 struct breakpoint
*b
;
509 extern struct breakpoint
*breakpoint_chain
;
512 error ("wrong # args");
514 for (b
= breakpoint_chain
; b
; b
= b
->next
)
515 if (b
->type
== bp_breakpoint
)
516 dsprintf_append_element (result_ptr
, "%d", b
->number
);
522 gdb_get_breakpoint_info (clientData
, interp
, argc
, argv
)
523 ClientData clientData
;
528 struct symtab_and_line sal
;
529 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
530 "finish", "watchpoint", "hardware watchpoint",
531 "read watchpoint", "access watchpoint",
532 "longjmp", "longjmp resume", "step resume",
533 "through sigtramp", "watchpoint scope",
535 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
536 struct command_line
*cmd
;
538 struct breakpoint
*b
;
539 extern struct breakpoint
*breakpoint_chain
;
540 char *funcname
, *fname
, *filename
;
543 error ("wrong # args");
545 bpnum
= atoi (argv
[1]);
547 for (b
= breakpoint_chain
; b
; b
= b
->next
)
548 if (b
->number
== bpnum
)
551 if (!b
|| b
->type
!= bp_breakpoint
)
552 error ("Breakpoint #%d does not exist", bpnum
);
554 sal
= find_pc_line (b
->address
, 0);
556 filename
= symtab_to_filename (sal
.symtab
);
557 if (filename
== NULL
)
559 Tcl_DStringAppendElement (result_ptr
, filename
);
561 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
562 fname
= cplus_demangle (funcname
, 0);
565 Tcl_DStringAppendElement (result_ptr
, fname
);
569 Tcl_DStringAppendElement (result_ptr
, funcname
);
570 dsprintf_append_element (result_ptr
, "%d", b
->line_number
);
571 dsprintf_append_element (result_ptr
, "0x%lx", b
->address
);
572 Tcl_DStringAppendElement (result_ptr
, bptypes
[b
->type
]);
573 Tcl_DStringAppendElement (result_ptr
, b
->enable
== enabled
? "1" : "0");
574 Tcl_DStringAppendElement (result_ptr
, bpdisp
[b
->disposition
]);
575 dsprintf_append_element (result_ptr
, "%d", b
->ignore_count
);
577 Tcl_DStringStartSublist (result_ptr
);
578 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
579 Tcl_DStringAppendElement (result_ptr
, cmd
->line
);
580 Tcl_DStringEndSublist (result_ptr
);
582 Tcl_DStringAppendElement (result_ptr
, b
->cond_string
);
584 dsprintf_append_element (result_ptr
, "%d", b
->thread
);
585 dsprintf_append_element (result_ptr
, "%d", b
->hit_count
);
591 breakpoint_notify(b
, action
)
592 struct breakpoint
*b
;
597 struct symtab_and_line sal
;
600 if (b
->type
!= bp_breakpoint
)
603 /* We ensure that ACTION contains no special Tcl characters, so we
605 sal
= find_pc_line (b
->address
, 0);
606 filename
= symtab_to_filename (sal
.symtab
);
607 if (filename
== NULL
)
610 sprintf (buf
, "gdbtk_tcl_breakpoint %s %d 0x%lx %d {%s}", action
, b
->number
,
611 (long)b
->address
, b
->line_number
, filename
);
613 v
= Tcl_Eval (interp
, buf
);
617 gdbtk_fputs (interp
->result
, gdb_stdout
);
618 gdbtk_fputs ("\n", gdb_stdout
);
623 gdbtk_create_breakpoint(b
)
624 struct breakpoint
*b
;
626 breakpoint_notify (b
, "create");
630 gdbtk_delete_breakpoint(b
)
631 struct breakpoint
*b
;
633 breakpoint_notify (b
, "delete");
637 gdbtk_modify_breakpoint(b
)
638 struct breakpoint
*b
;
640 breakpoint_notify (b
, "modify");
643 /* This implements the TCL command `gdb_loc', which returns a list */
644 /* consisting of the following: */
645 /* basename, function name, filename, line number, address, current pc */
648 gdb_loc (clientData
, interp
, argc
, argv
)
649 ClientData clientData
;
655 struct symtab_and_line sal
;
656 char *funcname
, *fname
;
659 if (!have_full_symbols () && !have_partial_symbols ())
661 Tcl_SetResult (interp
, "No symbol table is loaded", TCL_STATIC
);
667 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
669 /* Note - this next line is not correct on all architectures. */
670 /* For a graphical debugged we really want to highlight the */
671 /* assembly line that called the next function on the stack. */
672 /* Many architectures have the next instruction saved as the */
673 /* pc on the stack, so what happens is the next instruction is hughlighted. */
675 pc
= selected_frame
->pc
;
676 sal
= find_pc_line (selected_frame
->pc
,
677 selected_frame
->next
!= NULL
678 && !selected_frame
->next
->signal_handler_caller
679 && !frame_in_dummy (selected_frame
->next
));
684 sal
= find_pc_line (stop_pc
, 0);
689 struct symtabs_and_lines sals
;
692 sals
= decode_line_spec (argv
[1], 1);
699 error ("Ambiguous line spec");
704 error ("wrong # args");
707 Tcl_DStringAppendElement (result_ptr
, sal
.symtab
->filename
);
709 Tcl_DStringAppendElement (result_ptr
, "");
711 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
712 fname
= cplus_demangle (funcname
, 0);
715 Tcl_DStringAppendElement (result_ptr
, fname
);
719 Tcl_DStringAppendElement (result_ptr
, funcname
);
720 filename
= symtab_to_filename (sal
.symtab
);
721 if (filename
== NULL
)
724 Tcl_DStringAppendElement (result_ptr
, filename
);
725 dsprintf_append_element (result_ptr
, "%d", sal
.line
); /* line number */
726 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
727 dsprintf_append_element (result_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
731 /* This implements the TCL command `gdb_eval'. */
734 gdb_eval (clientData
, interp
, argc
, argv
)
735 ClientData clientData
;
740 struct expression
*expr
;
741 struct cleanup
*old_chain
;
745 error ("wrong # args");
747 expr
= parse_expression (argv
[1]);
749 old_chain
= make_cleanup (free_current_contents
, &expr
);
751 val
= evaluate_expression (expr
);
753 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
754 gdb_stdout
, 0, 0, 0, 0);
756 do_cleanups (old_chain
);
761 /* gdb_get_mem addr form size num aschar*/
762 /* dump a block of memory */
763 /* addr: address of data to dump */
764 /* form: a char indicating format */
765 /* size: size of each element; 1,2,4, or 8 bytes*/
766 /* num: the number of bytes to read */
767 /* acshar: an optional ascii character to use in ASCII dump */
768 /* returns a list of elements followed by an optional */
772 gdb_get_mem (clientData
, interp
, argc
, argv
)
773 ClientData clientData
;
778 int size
, asize
, i
, j
, bc
;
780 int nbytes
, rnum
, bpr
;
781 char format
, c
, *ptr
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
782 struct type
*val_type
;
784 if (argc
< 6 || argc
> 7)
786 interp
->result
= "addr format size bytes bytes_per_row ?ascii_char?";
790 size
= (int)strtoul(argv
[3],(char **)NULL
,0);
791 nbytes
= (int)strtoul(argv
[4],(char **)NULL
,0);
792 bpr
= (int)strtoul(argv
[5],(char **)NULL
,0);
793 if (nbytes
<= 0 || bpr
<= 0 || size
<= 0)
795 interp
->result
= "Invalid number of bytes.";
799 addr
= (CORE_ADDR
)strtoul(argv
[1],(char **)NULL
,0);
801 mbuf
= (char *)malloc (nbytes
+32);
804 interp
->result
= "Out of memory.";
807 memset (mbuf
, 0, nbytes
+32);
810 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
819 val_type
= builtin_type_char
;
823 val_type
= builtin_type_short
;
827 val_type
= builtin_type_int
;
831 val_type
= builtin_type_long_long
;
835 val_type
= builtin_type_char
;
839 bc
= 0; /* count of bytes in a row */
840 buff
[0] = '"'; /* buffer for ascii dump */
841 bptr
= &buff
[1]; /* pointer for ascii dump */
843 for (i
=0; i
< nbytes
; i
+= size
)
847 fputs_unfiltered ("N/A ", gdb_stdout
);
849 for ( j
= 0; j
< size
; j
++)
854 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
855 fputs_unfiltered (" ", gdb_stdout
);
858 for ( j
= 0; j
< size
; j
++)
861 if (c
< 32 || c
> 126)
873 if (aschar
&& (bc
>= bpr
))
875 /* end of row. print it and reset variables */
880 fputs_unfiltered (buff
, gdb_stdout
);
890 map_arg_registers (argc
, argv
, func
, argp
)
893 void (*func
) PARAMS ((int regnum
, void *argp
));
898 /* Note that the test for a valid register must include checking the
899 reg_names array because NUM_REGS may be allocated for the union of the
900 register sets within a family of related processors. In this case, the
901 trailing entries of reg_names will change depending upon the particular
902 processor being debugged. */
904 if (argc
== 0) /* No args, just do all the regs */
908 && reg_names
[regnum
] != NULL
909 && *reg_names
[regnum
] != '\000';
916 /* Else, list of register #s, just do listed regs */
917 for (; argc
> 0; argc
--, argv
++)
919 regnum
= atoi (*argv
);
923 && reg_names
[regnum
] != NULL
924 && *reg_names
[regnum
] != '\000')
927 error ("bad register number");
934 get_register_name (regnum
, argp
)
936 void *argp
; /* Ignored */
938 Tcl_DStringAppendElement (result_ptr
, reg_names
[regnum
]);
941 /* This implements the TCL command `gdb_regnames', which returns a list of
942 all of the register names. */
945 gdb_regnames (clientData
, interp
, argc
, argv
)
946 ClientData clientData
;
954 return map_arg_registers (argc
, argv
, get_register_name
, NULL
);
957 #ifndef REGISTER_CONVERTIBLE
958 #define REGISTER_CONVERTIBLE(x) (0 != 0)
961 #ifndef REGISTER_CONVERT_TO_VIRTUAL
962 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
965 #ifndef INVALID_FLOAT
966 #define INVALID_FLOAT(x, y) (0 != 0)
970 get_register (regnum
, fp
)
974 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
975 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
976 int format
= (int)fp
;
981 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
983 Tcl_DStringAppendElement (result_ptr
, "Optimized out");
987 /* Convert raw data to virtual format if necessary. */
989 if (REGISTER_CONVERTIBLE (regnum
))
991 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
992 raw_buffer
, virtual_buffer
);
995 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1000 printf_filtered ("0x");
1001 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1003 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1004 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1005 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
1009 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
1010 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1012 Tcl_DStringAppend (result_ptr
, " ", -1);
1016 get_pc_register (clientData
, interp
, argc
, argv
)
1017 ClientData clientData
;
1022 sprintf(interp
->result
,"0x%llx",(long long)read_register(PC_REGNUM
));
1027 gdb_fetch_registers (clientData
, interp
, argc
, argv
)
1028 ClientData clientData
;
1036 error ("wrong # args");
1042 return map_arg_registers (argc
, argv
, get_register
, (void *) format
);
1045 /* This contains the previous values of the registers, since the last call to
1046 gdb_changed_register_list. */
1048 static char old_regs
[REGISTER_BYTES
];
1051 register_changed_p (regnum
, argp
)
1053 void *argp
; /* Ignored */
1055 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1057 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1060 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1061 REGISTER_RAW_SIZE (regnum
)) == 0)
1064 /* Found a changed register. Save new value and return its number. */
1066 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1067 REGISTER_RAW_SIZE (regnum
));
1069 dsprintf_append_element (result_ptr
, "%d", regnum
);
1073 gdb_changed_register_list (clientData
, interp
, argc
, argv
)
1074 ClientData clientData
;
1082 return map_arg_registers (argc
, argv
, register_changed_p
, NULL
);
1085 /* This implements the tcl command "gdb_immediate", which does exactly
1086 the same thing as gdb_cmd, except NONE of its outut is buffered. */
1087 /* This will also ALWAYS cause the busy,update, and idle hooks to be
1088 called, contrasted with gdb_cmd, which NEVER calls them. */
1090 gdb_immediate_command (clientData
, interp
, argc
, argv
)
1091 ClientData clientData
;
1096 Tcl_DString
*save_ptr
= NULL
;
1099 error ("wrong # args");
1101 if (running_now
|| load_in_progress
)
1106 Tcl_DStringAppend (result_ptr
, "", -1);
1107 save_ptr
= result_ptr
;
1110 execute_command (argv
[1], 1);
1112 bpstat_do_actions (&stop_bpstat
);
1114 result_ptr
= save_ptr
;
1119 /* This implements the TCL command `gdb_cmd', which sends its argument into
1120 the GDB command scanner. */
1121 /* This command will never cause the update, idle and busy hooks to be called
1124 gdb_cmd (clientData
, interp
, argc
, argv
)
1125 ClientData clientData
;
1130 Tcl_DString
*save_ptr
= NULL
;
1133 error ("wrong # args");
1135 if (running_now
|| load_in_progress
)
1140 /* for the load instruction (and possibly others later) we
1141 set result_ptr to NULL so gdbtk_fputs() will not buffer
1142 all the data until the command is finished. */
1144 if (strncmp ("load ", argv
[1], 5) == 0
1145 || strncmp ("while ", argv
[1], 6) == 0)
1147 Tcl_DStringAppend (result_ptr
, "", -1);
1148 save_ptr
= result_ptr
;
1150 load_in_progress
= 1;
1151 gdbtk_start_timer ();
1154 execute_command (argv
[1], 1);
1156 if (load_in_progress
)
1158 gdbtk_stop_timer ();
1159 load_in_progress
= 0;
1162 bpstat_do_actions (&stop_bpstat
);
1165 result_ptr
= save_ptr
;
1170 /* Client of call_wrapper - this routine performs the actual call to
1171 the client function. */
1173 struct wrapped_call_args
1184 struct wrapped_call_args
*args
;
1186 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->argc
, args
->argv
);
1190 struct wrapped_call_objs
1193 Tcl_ObjCmdProc
*func
;
1195 Tcl_Obj
* CONST
*objv
;
1200 wrapped_obj_call (args
)
1201 struct wrapped_call_objs
*args
;
1203 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->objc
, args
->objv
);
1207 /* This routine acts as a top-level for all GDB code called by tcl/Tk. It
1208 handles cleanups, and calls to return_to_top_level (usually via error).
1209 This is necessary in order to prevent a longjmp out of the bowels of Tk,
1210 possibly leaving things in a bad state. Since this routine can be called
1211 recursively, it needs to save and restore the contents of the jmp_buf as
1215 call_wrapper (clientData
, interp
, argc
, argv
)
1216 ClientData clientData
;
1221 struct wrapped_call_args wrapped_args
;
1222 Tcl_DString result
, *old_result_ptr
;
1223 Tcl_DString error_string
, *old_error_string_ptr
;
1225 Tcl_DStringInit (&result
);
1226 old_result_ptr
= result_ptr
;
1227 result_ptr
= &result
;
1229 Tcl_DStringInit (&error_string
);
1230 old_error_string_ptr
= error_string_ptr
;
1231 error_string_ptr
= &error_string
;
1233 wrapped_args
.func
= (Tcl_CmdProc
*)clientData
;
1234 wrapped_args
.interp
= interp
;
1235 wrapped_args
.argc
= argc
;
1236 wrapped_args
.argv
= argv
;
1237 wrapped_args
.val
= 0;
1239 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
1241 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
1243 /* Make sure the timer interrupts are turned off. */
1244 if (gdbtk_timer_going
)
1245 gdbtk_stop_timer ();
1247 gdb_flush (gdb_stderr
); /* Flush error output */
1248 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
1250 /* In case of an error, we may need to force the GUI into idle
1251 mode because gdbtk_call_command may have bombed out while in
1252 the command routine. */
1255 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1258 /* do not suppress any errors -- a remote target could have errored */
1259 load_in_progress
= 0;
1261 if (Tcl_DStringLength (&error_string
) == 0)
1263 Tcl_DStringResult (interp
, &result
);
1264 Tcl_DStringFree (&error_string
);
1266 else if (Tcl_DStringLength (&result
) == 0)
1268 Tcl_DStringResult (interp
, &error_string
);
1269 Tcl_DStringFree (&result
);
1270 Tcl_DStringFree (&error_string
);
1274 Tcl_ResetResult (interp
);
1275 Tcl_AppendResult (interp
, Tcl_DStringValue (&result
),
1276 Tcl_DStringValue (&error_string
), (char *) NULL
);
1277 Tcl_DStringFree (&result
);
1278 Tcl_DStringFree (&error_string
);
1281 result_ptr
= old_result_ptr
;
1282 error_string_ptr
= old_error_string_ptr
;
1288 return wrapped_args
.val
;
1291 call_obj_wrapper (clientData
, interp
, objc
, objv
)
1292 ClientData clientData
;
1295 Tcl_Obj
*CONST objv
[];
1297 struct wrapped_call_objs wrapped_args
;
1298 Tcl_DString result
, *old_result_ptr
;
1299 Tcl_DString error_string
, *old_error_string_ptr
;
1301 /* The obj call wrapper works differently from the string wrapper, because
1302 * the obj calls currently insert their results directly into the
1303 * interpreter's result. So there is no need to have a result_ptr...
1304 * FIXME - rewrite all the object commands so they use a result_obj_ptr
1305 * - rewrite all the string commands to be object commands.
1308 Tcl_DStringInit (&result
);
1309 old_result_ptr
= result_ptr
;
1310 result_ptr
= &result
;
1312 Tcl_DStringInit (&error_string
);
1314 Tcl_DStringInit (&error_string
);
1315 old_error_string_ptr
= error_string_ptr
;
1316 error_string_ptr
= &error_string
;
1318 wrapped_args
.func
= (Tcl_ObjCmdProc
*)clientData
;
1319 wrapped_args
.interp
= interp
;
1320 wrapped_args
.objc
= objc
;
1321 wrapped_args
.objv
= objv
;
1322 wrapped_args
.val
= 0;
1324 if (!catch_errors (wrapped_obj_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
1326 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
1328 /* Make sure the timer interrupts are turned off. */
1329 if (gdbtk_timer_going
)
1330 gdbtk_stop_timer ();
1332 gdb_flush (gdb_stderr
); /* Flush error output */
1333 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
1335 /* In case of an error, we may need to force the GUI into idle
1336 mode because gdbtk_call_command may have bombed out while in
1337 the command routine. */
1340 Tcl_Eval (interp
, "gdbtk_tcl_idle");
1341 /* if the error message is in RESULT instead of ERROR_STRING we copy it
1342 back to ERROR_STRING and free RESULT */
1344 if ((Tcl_DStringLength (&error_string
) == 0) &&
1345 (Tcl_DStringLength (&result
) > 0))
1347 Tcl_DStringAppend (&error_string
, Tcl_DStringValue (&result
),
1348 Tcl_DStringLength (&result
));
1349 Tcl_DStringFree (&result
);
1353 /* do not suppress any errors -- a remote target could have errored */
1354 load_in_progress
= 0;
1356 if (Tcl_DStringLength (&error_string
) == 0)
1358 /* We should insert the result here, but the obj commands now
1359 * do this directly, so we don't need to.
1360 * FIXME - ultimately, all this should be redone so that all the
1361 * commands either manipulate the Tcl result directly, or use a result_ptr.
1364 Tcl_DStringFree (&error_string
);
1366 else if (*(Tcl_GetStringResult (interp
)) == '\0')
1368 Tcl_DStringResult (interp
, &error_string
);
1369 Tcl_DStringFree (&error_string
);
1373 Tcl_AppendToObj(Tcl_GetObjResult(interp
), Tcl_DStringValue (&error_string
),
1374 Tcl_DStringLength (&error_string
));
1375 Tcl_DStringFree (&error_string
);
1378 result_ptr
= old_result_ptr
;
1379 error_string_ptr
= old_error_string_ptr
;
1385 return wrapped_args
.val
;
1389 comp_files (file1
, file2
)
1390 const char *file1
[], *file2
[];
1392 return strcmp(*file1
,*file2
);
1396 gdb_listfiles (clientData
, interp
, objc
, objv
)
1397 ClientData clientData
;
1400 Tcl_Obj
*CONST objv
[];
1402 struct objfile
*objfile
;
1403 struct partial_symtab
*psymtab
;
1404 struct symtab
*symtab
;
1405 char *lastfile
, *pathname
, **files
;
1407 int i
, numfiles
= 0, len
= 0;
1411 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1415 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1419 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1421 mylist
= Tcl_NewListObj (0, NULL
);
1423 ALL_PSYMTABS (objfile
, psymtab
)
1425 if (numfiles
== files_size
)
1427 files_size
= files_size
* 2;
1428 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1432 if (psymtab
->filename
)
1433 files
[numfiles
++] = basename(psymtab
->filename
);
1435 else if (!strcmp(psymtab
->filename
,basename(psymtab
->filename
))
1436 || !strncmp(pathname
,psymtab
->filename
,len
))
1437 if (psymtab
->filename
)
1438 files
[numfiles
++] = basename(psymtab
->filename
);
1441 ALL_SYMTABS (objfile
, symtab
)
1443 if (numfiles
== files_size
)
1445 files_size
= files_size
* 2;
1446 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1450 if (symtab
->filename
)
1451 files
[numfiles
++] = basename(symtab
->filename
);
1453 else if (!strcmp(symtab
->filename
,basename(symtab
->filename
))
1454 || !strncmp(pathname
,symtab
->filename
,len
))
1455 if (symtab
->filename
)
1456 files
[numfiles
++] = basename(symtab
->filename
);
1459 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1462 for (i
= 0; i
< numfiles
; i
++)
1464 if (strcmp(files
[i
],lastfile
))
1465 Tcl_ListObjAppendElement (interp
, mylist
, Tcl_NewStringObj(files
[i
], -1));
1466 lastfile
= files
[i
];
1468 Tcl_SetObjResult (interp
, mylist
);
1474 gdb_listfuncs (clientData
, interp
, argc
, argv
)
1475 ClientData clientData
;
1480 struct symtab
*symtab
;
1481 struct blockvector
*bv
;
1488 error ("wrong # args");
1490 symtab
= full_lookup_symtab (argv
[1]);
1492 error ("No such file");
1494 bv
= BLOCKVECTOR (symtab
);
1495 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1497 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1498 /* Skip the sort if this block is always sorted. */
1499 if (!BLOCK_SHOULD_SORT (b
))
1500 sort_block_syms (b
);
1501 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1503 sym
= BLOCK_SYM (b
, j
);
1504 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1507 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1510 sprintf (buf
,"{%s} 1", name
);
1513 sprintf (buf
,"{%s} 0", SYMBOL_NAME(sym
));
1514 Tcl_DStringAppendElement (result_ptr
, buf
);
1522 target_stop_wrapper (args
)
1530 gdb_stop (clientData
, interp
, argc
, argv
)
1531 ClientData clientData
;
1538 catch_errors (target_stop_wrapper
, NULL
, "",
1542 quit_flag
= 1; /* hope something sees this */
1547 /* Prepare to accept a new executable file. This is called when we
1548 want to clear away everything we know about the old file, without
1549 asking the user. The Tcl code will have already asked the user if
1550 necessary. After this is called, we should be able to run the
1551 `file' command without getting any questions. */
1554 gdb_clear_file (clientData
, interp
, argc
, argv
)
1555 ClientData clientData
;
1560 if (inferior_pid
!= 0 && target_has_execution
)
1563 target_detach (NULL
, 0);
1568 if (target_has_execution
)
1571 symbol_file_command (NULL
, 0);
1573 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
1574 clear it here. FIXME: This seems like an abstraction violation
1581 /* Ask the user to confirm an exit request. */
1584 gdb_confirm_quit (clientData
, interp
, argc
, argv
)
1585 ClientData clientData
;
1592 ret
= quit_confirm ();
1593 Tcl_DStringAppendElement (result_ptr
, ret
? "1" : "0");
1597 /* Quit without asking for confirmation. */
1600 gdb_force_quit (clientData
, interp
, argc
, argv
)
1601 ClientData clientData
;
1606 quit_force ((char *) NULL
, 1);
1610 /* This implements the TCL command `gdb_disassemble'. */
1613 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
1617 disassemble_info
*info
;
1619 extern struct target_ops exec_ops
;
1623 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
1634 /* We need a different sort of line table from the normal one cuz we can't
1635 depend upon implicit line-end pc's for lines. This is because of the
1636 reordering we are about to do. */
1638 struct my_line_entry
{
1645 compare_lines (mle1p
, mle2p
)
1649 struct my_line_entry
*mle1
, *mle2
;
1652 mle1
= (struct my_line_entry
*) mle1p
;
1653 mle2
= (struct my_line_entry
*) mle2p
;
1655 val
= mle1
->line
- mle2
->line
;
1660 return mle1
->start_pc
- mle2
->start_pc
;
1664 gdb_disassemble (clientData
, interp
, argc
, argv
)
1665 ClientData clientData
;
1670 CORE_ADDR pc
, low
, high
;
1671 int mixed_source_and_assembly
;
1672 static disassemble_info di
;
1673 static int di_initialized
;
1675 if (! di_initialized
)
1677 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
1678 (fprintf_ftype
) fprintf_unfiltered
);
1679 di
.flavour
= bfd_target_unknown_flavour
;
1680 di
.memory_error_func
= dis_asm_memory_error
;
1681 di
.print_address_func
= dis_asm_print_address
;
1685 di
.mach
= tm_print_insn_info
.mach
;
1686 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
1687 di
.endian
= BFD_ENDIAN_BIG
;
1689 di
.endian
= BFD_ENDIAN_LITTLE
;
1691 if (argc
!= 3 && argc
!= 4)
1692 error ("wrong # args");
1694 if (strcmp (argv
[1], "source") == 0)
1695 mixed_source_and_assembly
= 1;
1696 else if (strcmp (argv
[1], "nosource") == 0)
1697 mixed_source_and_assembly
= 0;
1699 error ("First arg must be 'source' or 'nosource'");
1701 low
= parse_and_eval_address (argv
[2]);
1705 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
1706 error ("No function contains specified address");
1709 high
= parse_and_eval_address (argv
[3]);
1711 /* If disassemble_from_exec == -1, then we use the following heuristic to
1712 determine whether or not to do disassembly from target memory or from the
1715 If we're debugging a local process, read target memory, instead of the
1716 exec file. This makes disassembly of functions in shared libs work
1719 Else, we're debugging a remote process, and should disassemble from the
1720 exec file for speed. However, this is no good if the target modifies its
1721 code (for relocation, or whatever).
1724 if (disassemble_from_exec
== -1)
1725 if (strcmp (target_shortname
, "child") == 0
1726 || strcmp (target_shortname
, "procfs") == 0
1727 || strcmp (target_shortname
, "vxprocess") == 0)
1728 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
1730 disassemble_from_exec
= 1; /* It's remote, read the exec file */
1732 if (disassemble_from_exec
)
1733 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
1735 di
.read_memory_func
= dis_asm_read_memory
;
1737 /* If just doing straight assembly, all we need to do is disassemble
1738 everything between low and high. If doing mixed source/assembly, we've
1739 got a totally different path to follow. */
1741 if (mixed_source_and_assembly
)
1742 { /* Come here for mixed source/assembly */
1743 /* The idea here is to present a source-O-centric view of a function to
1744 the user. This means that things are presented in source order, with
1745 (possibly) out of order assembly immediately following. */
1746 struct symtab
*symtab
;
1747 struct linetable_entry
*le
;
1750 struct my_line_entry
*mle
;
1751 struct symtab_and_line sal
;
1756 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
1761 /* First, convert the linetable to a bunch of my_line_entry's. */
1763 le
= symtab
->linetable
->item
;
1764 nlines
= symtab
->linetable
->nitems
;
1769 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
1773 /* Copy linetable entries for this function into our data structure, creating
1774 end_pc's and setting out_of_order as appropriate. */
1776 /* First, skip all the preceding functions. */
1778 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
1780 /* Now, copy all entries before the end of this function. */
1783 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
1785 if (le
[i
].line
== le
[i
+ 1].line
1786 && le
[i
].pc
== le
[i
+ 1].pc
)
1787 continue; /* Ignore duplicates */
1789 mle
[newlines
].line
= le
[i
].line
;
1790 if (le
[i
].line
> le
[i
+ 1].line
)
1792 mle
[newlines
].start_pc
= le
[i
].pc
;
1793 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
1797 /* If we're on the last line, and it's part of the function, then we need to
1798 get the end pc in a special way. */
1803 mle
[newlines
].line
= le
[i
].line
;
1804 mle
[newlines
].start_pc
= le
[i
].pc
;
1805 sal
= find_pc_line (le
[i
].pc
, 0);
1806 mle
[newlines
].end_pc
= sal
.end
;
1810 /* Now, sort mle by line #s (and, then by addresses within lines). */
1813 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
1815 /* Now, for each line entry, emit the specified lines (unless they have been
1816 emitted before), followed by the assembly code for that line. */
1818 next_line
= 0; /* Force out first line */
1819 for (i
= 0; i
< newlines
; i
++)
1821 /* Print out everything from next_line to the current line. */
1823 if (mle
[i
].line
>= next_line
)
1826 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
1828 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
1830 next_line
= mle
[i
].line
+ 1;
1833 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
1836 fputs_unfiltered (" ", gdb_stdout
);
1837 print_address (pc
, gdb_stdout
);
1838 fputs_unfiltered (":\t ", gdb_stdout
);
1839 pc
+= (*tm_print_insn
) (pc
, &di
);
1840 fputs_unfiltered ("\n", gdb_stdout
);
1847 for (pc
= low
; pc
< high
; )
1850 fputs_unfiltered (" ", gdb_stdout
);
1851 print_address (pc
, gdb_stdout
);
1852 fputs_unfiltered (":\t ", gdb_stdout
);
1853 pc
+= (*tm_print_insn
) (pc
, &di
);
1854 fputs_unfiltered ("\n", gdb_stdout
);
1858 gdb_flush (gdb_stdout
);
1864 tk_command (cmd
, from_tty
)
1870 struct cleanup
*old_chain
;
1872 /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1874 error_no_arg ("tcl command to interpret");
1876 retval
= Tcl_Eval (interp
, cmd
);
1878 result
= strdup (interp
->result
);
1880 old_chain
= make_cleanup (free
, result
);
1882 if (retval
!= TCL_OK
)
1885 printf_unfiltered ("%s\n", result
);
1887 do_cleanups (old_chain
);
1891 cleanup_init (ignored
)
1895 Tcl_DeleteInterp (interp
);
1899 /* Come here during long calculations to check for GUI events. Usually invoked
1900 via the QUIT macro. */
1903 gdbtk_interactive ()
1905 /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1908 /* Come here when there is activity on the X file descriptor. */
1914 static int in_x_event
= 0;
1915 static Tcl_Obj
*varname
= NULL
;
1916 if (in_x_event
|| in_fputs
)
1923 if (gdbtk_timer_going
)
1924 gdbtk_stop_timer ();
1927 /* Process pending events */
1928 while (Tcl_DoOneEvent (TCL_DONT_WAIT
|TCL_ALL_EVENTS
) != 0)
1931 if (load_in_progress
)
1934 if (varname
== NULL
)
1936 Tcl_Obj
*varnamestrobj
= Tcl_NewStringObj("download_cancel_ok",-1);
1937 varname
= Tcl_ObjGetVar2(interp
,varnamestrobj
,NULL
,TCL_GLOBAL_ONLY
);
1939 if ((Tcl_GetIntFromObj(interp
,varname
,&val
) == TCL_OK
) && val
)
1953 /* For Cygwin32, we use a timer to periodically check for Windows
1954 messages. FIXME: It would be better to not poll, but to instead
1955 rewrite the target_wait routines to serve as input sources.
1956 Unfortunately, that will be a lot of work. */
1957 static sigset_t nullsigmask
;
1958 static struct sigaction act1
, act2
;
1959 static struct itimerval it_on
, it_off
;
1962 gdbtk_start_timer ()
1964 static int first
= 1;
1965 /*TclDebug ("Starting timer....");*/
1968 /* first time called, set up all the structs */
1970 sigemptyset (&nullsigmask
);
1972 act1
.sa_handler
= x_event
;
1973 act1
.sa_mask
= nullsigmask
;
1976 act2
.sa_handler
= SIG_IGN
;
1977 act2
.sa_mask
= nullsigmask
;
1980 it_on
.it_interval
.tv_sec
= 0;
1981 it_on
.it_interval
.tv_usec
= 250000; /* .25 sec */
1982 it_on
.it_value
.tv_sec
= 0;
1983 it_on
.it_value
.tv_usec
= 250000;
1985 it_off
.it_interval
.tv_sec
= 0;
1986 it_off
.it_interval
.tv_usec
= 0;
1987 it_off
.it_value
.tv_sec
= 0;
1988 it_off
.it_value
.tv_usec
= 0;
1991 if (!gdbtk_timer_going
)
1993 sigaction (SIGALRM
, &act1
, NULL
);
1994 setitimer (ITIMER_REAL
, &it_on
, NULL
);
1995 gdbtk_timer_going
= 1;
2002 if (gdbtk_timer_going
)
2004 gdbtk_timer_going
= 0;
2005 /*TclDebug ("Stopping timer.");*/
2006 setitimer (ITIMER_REAL
, &it_off
, NULL
);
2007 sigaction (SIGALRM
, &act2
, NULL
);
2011 /* This hook function is called whenever we want to wait for the
2015 gdbtk_wait (pid
, ourstatus
)
2017 struct target_waitstatus
*ourstatus
;
2019 gdbtk_start_timer ();
2020 pid
= target_wait (pid
, ourstatus
);
2021 gdbtk_stop_timer ();
2025 /* This is called from execute_command, and provides a wrapper around
2026 various command routines in a place where both protocol messages and
2027 user input both flow through. Mostly this is used for indicating whether
2028 the target process is running or not.
2032 gdbtk_call_command (cmdblk
, arg
, from_tty
)
2033 struct cmd_list_element
*cmdblk
;
2038 if (cmdblk
->class == class_run
|| cmdblk
->class == class_trace
)
2041 /* HACK! HACK! This is to get the gui to update the tstart/tstop
2042 button only incase of tstart/tstop commands issued from the console
2043 We don't want to update the src window, so we need to have specific
2044 procedures to do tstart and tstop
2045 Unfortunately this will not display errors from tstart or tstop in the
2046 console window itself, but as dialogs.*/
2048 if (!strcmp(cmdblk
->name
, "tstart") && !No_Update
)
2050 Tcl_Eval (interp
, "gdbtk_tcl_tstart");
2051 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
2053 else if (!strcmp(cmdblk
->name
, "tstop") && !No_Update
)
2055 Tcl_Eval (interp
, "gdbtk_tcl_tstop");
2056 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
2063 Tcl_Eval (interp
, "gdbtk_tcl_busy");
2064 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
2067 Tcl_Eval (interp
, "gdbtk_tcl_idle");
2071 (*cmdblk
->function
.cfunc
)(arg
, from_tty
);
2074 /* This function is called instead of gdb's internal command loop. This is the
2075 last chance to do anything before entering the main Tk event loop. */
2080 extern GDB_FILE
*instream
;
2082 /* We no longer want to use stdin as the command input stream */
2085 if (Tcl_Eval (interp
, "gdbtk_tcl_preloop") != TCL_OK
)
2089 /* Force errorInfo to be set up propertly. */
2090 Tcl_AddErrorInfo (interp
, "");
2092 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
2094 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
2096 fputs_unfiltered (msg
, gdb_stderr
);
2107 /* gdbtk_init installs this function as a final cleanup. */
2110 gdbtk_cleanup (dummy
)
2114 struct ide_event_handle
*h
= (struct ide_event_handle
*) dummy
;
2116 ide_interface_deregister_all (h
);
2121 /* Initialize gdbtk. */
2124 gdbtk_init ( argv0
)
2127 struct cleanup
*old_chain
;
2128 char *lib
, *gdbtk_lib
, *gdbtk_lib_tmp
, *gdbtk_file
;
2130 Tcl_Obj
*auto_path_elem
, *auto_path_name
;
2132 struct sigaction action
;
2133 static sigset_t nullsigmask
= {0};
2136 /* start-sanitize-ide */
2137 struct ide_event_handle
*h
;
2140 /* end-sanitize-ide */
2143 /* If there is no DISPLAY environment variable, Tk_Init below will fail,
2144 causing gdb to abort. If instead we simply return here, gdb will
2145 gracefully degrade to using the command line interface. */
2148 if (getenv ("DISPLAY") == NULL
)
2152 old_chain
= make_cleanup (cleanup_init
, 0);
2154 /* First init tcl and tk. */
2155 Tcl_FindExecutable (argv0
);
2156 interp
= Tcl_CreateInterp ();
2158 #ifdef TCL_MEM_DEBUG
2159 Tcl_InitMemory (interp
);
2163 error ("Tcl_CreateInterp failed");
2165 if (Tcl_Init(interp
) != TCL_OK
)
2166 error ("Tcl_Init failed: %s", interp
->result
);
2169 /* For the IDE we register the cleanup later, after we've
2170 initialized events. */
2171 make_final_cleanup (gdbtk_cleanup
, NULL
);
2174 /* Initialize the Paths variable. */
2175 if (ide_initialize_paths (interp
, "gdbtcl") != TCL_OK
)
2176 error ("ide_initialize_paths failed: %s", interp
->result
);
2179 /* start-sanitize-ide */
2180 /* Find the directory where we expect to find idemanager. We ignore
2181 errors since it doesn't really matter if this fails. */
2182 libexecdir
= Tcl_GetVar2 (interp
, "Paths", "libexecdir", TCL_GLOBAL_ONLY
);
2186 h
= ide_event_init_from_environment (&errmsg
, libexecdir
);
2187 make_final_cleanup (gdbtk_cleanup
, h
);
2190 Tcl_AppendResult (interp
, "can't initialize event system: ", errmsg
,
2192 fprintf(stderr
, "WARNING: ide_event_init_client failed: %s\n", interp
->result
);
2194 Tcl_SetVar (interp
, "IDE_ENABLED", "0", 0);
2198 if (ide_create_tclevent_command (interp
, h
) != TCL_OK
)
2199 error ("ide_create_tclevent_command failed: %s", interp
->result
);
2201 if (ide_create_edit_command (interp
, h
) != TCL_OK
)
2202 error ("ide_create_edit_command failed: %s", interp
->result
);
2204 if (ide_create_property_command (interp
, h
) != TCL_OK
)
2205 error ("ide_create_property_command failed: %s", interp
->result
);
2207 if (ide_create_build_command (interp
, h
) != TCL_OK
)
2208 error ("ide_create_build_command failed: %s", interp
->result
);
2210 if (ide_create_window_register_command (interp
, h
, "gdb-restore")
2212 error ("ide_create_window_register_command failed: %s",
2215 if (ide_create_window_command (interp
, h
) != TCL_OK
)
2216 error ("ide_create_window_command failed: %s", interp
->result
);
2218 if (ide_create_exit_command (interp
, h
) != TCL_OK
)
2219 error ("ide_create_exit_command failed: %s", interp
->result
);
2221 if (ide_create_help_command (interp
) != TCL_OK
)
2222 error ("ide_create_help_command failed: %s", interp
->result
);
2225 if (ide_initialize (interp, "gdb") != TCL_OK)
2226 error ("ide_initialize failed: %s", interp->result);
2229 Tcl_SetVar (interp
, "IDE_ENABLED", "1", 0);
2231 /* end-sanitize-ide */
2233 Tcl_SetVar (interp
, "IDE_ENABLED", "0", 0);
2236 /* We don't want to open the X connection until we've done all the
2237 IDE initialization. Otherwise, goofy looking unfinished windows
2238 pop up when ILU drops into the TCL event loop. */
2240 if (Tk_Init(interp
) != TCL_OK
)
2241 error ("Tk_Init failed: %s", interp
->result
);
2243 if (Itcl_Init(interp
) == TCL_ERROR
)
2244 error ("Itcl_Init failed: %s", interp
->result
);
2246 if (Tix_Init(interp
) != TCL_OK
)
2247 error ("Tix_Init failed: %s", interp
->result
);
2249 if (Tktable_Init(interp
) != TCL_OK
)
2250 error ("Tktable_Init failed: %s", interp
->result
);
2251 Tcl_StaticPackage(interp
, "Tktable", Tktable_Init
,
2252 (Tcl_PackageInitProc
*) NULL
);
2255 if (ide_create_messagebox_command (interp
) != TCL_OK
)
2256 error ("messagebox command initialization failed");
2257 /* On Windows, create a sizebox widget command */
2258 if (ide_create_sizebox_command (interp
) != TCL_OK
)
2259 error ("sizebox creation failed");
2260 if (ide_create_winprint_command (interp
) != TCL_OK
)
2261 error ("windows print code initialization failed");
2262 /* start-sanitize-ide */
2263 /* An interface to ShellExecute. */
2264 if (ide_create_shell_execute_command (interp
) != TCL_OK
)
2265 error ("shell execute command initialization failed");
2266 /* end-sanitize-ide */
2267 if (ide_create_win_grab_command (interp
) != TCL_OK
)
2268 error ("grab support command initialization failed");
2269 /* Path conversion functions. */
2270 if (ide_create_cygwin_path_command (interp
) != TCL_OK
)
2271 error ("cygwin path command initialization failed");
2274 Tcl_CreateCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
2275 Tcl_CreateCommand (interp
, "gdb_immediate", call_wrapper
,
2276 gdb_immediate_command
, NULL
);
2277 Tcl_CreateCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
2278 Tcl_CreateCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
2279 Tcl_CreateObjCommand (interp
, "gdb_listfiles", call_obj_wrapper
, gdb_listfiles
, NULL
);
2280 Tcl_CreateCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
2282 Tcl_CreateCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
2284 Tcl_CreateCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
2285 Tcl_CreateCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
2286 Tcl_CreateCommand (interp
, "gdb_fetch_registers", call_wrapper
,
2287 gdb_fetch_registers
, NULL
);
2288 Tcl_CreateCommand (interp
, "gdb_changed_register_list", call_wrapper
,
2289 gdb_changed_register_list
, NULL
);
2290 Tcl_CreateCommand (interp
, "gdb_disassemble", call_wrapper
,
2291 gdb_disassemble
, NULL
);
2292 Tcl_CreateCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
2293 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
2294 gdb_get_breakpoint_list
, NULL
);
2295 Tcl_CreateCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
2296 gdb_get_breakpoint_info
, NULL
);
2297 Tcl_CreateCommand (interp
, "gdb_clear_file", call_wrapper
,
2298 gdb_clear_file
, NULL
);
2299 Tcl_CreateCommand (interp
, "gdb_confirm_quit", call_wrapper
,
2300 gdb_confirm_quit
, NULL
);
2301 Tcl_CreateCommand (interp
, "gdb_force_quit", call_wrapper
,
2302 gdb_force_quit
, NULL
);
2303 Tcl_CreateCommand (interp
, "gdb_target_has_execution",
2304 gdb_target_has_execution_command
,
2306 Tcl_CreateCommand (interp
, "gdb_is_tracing",
2309 Tcl_CreateObjCommand (interp
, "gdb_load_info", call_obj_wrapper
, gdb_load_info
, NULL
);
2310 Tcl_CreateObjCommand (interp
, "gdb_get_locals", call_obj_wrapper
, gdb_get_locals_command
,
2312 Tcl_CreateObjCommand (interp
, "gdb_get_args", call_obj_wrapper
, gdb_get_args_command
,
2314 Tcl_CreateObjCommand (interp
, "gdb_get_function", call_obj_wrapper
, gdb_get_function_command
,
2316 Tcl_CreateObjCommand (interp
, "gdb_get_line", call_obj_wrapper
, gdb_get_line_command
,
2318 Tcl_CreateObjCommand (interp
, "gdb_get_file", call_obj_wrapper
, gdb_get_file_command
,
2320 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
2321 call_obj_wrapper
, gdb_tracepoint_exists_command
, NULL
);
2322 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
2323 call_obj_wrapper
, gdb_get_tracepoint_info
, NULL
);
2324 Tcl_CreateObjCommand (interp
, "gdb_actions",
2325 call_obj_wrapper
, gdb_actions_command
, NULL
);
2326 Tcl_CreateObjCommand (interp
, "gdb_prompt",
2327 call_obj_wrapper
, gdb_prompt_command
, NULL
);
2328 Tcl_CreateObjCommand (interp
, "gdb_find_file",
2329 call_obj_wrapper
, gdb_find_file_command
, NULL
);
2330 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
2331 call_obj_wrapper
, gdb_get_tracepoint_list
, NULL
);
2332 Tcl_CreateCommand (interp
, "gdb_pc_reg", get_pc_register
, NULL
, NULL
);
2333 Tcl_CreateObjCommand (interp
, "gdb_loadfile", call_obj_wrapper
, gdb_loadfile
, NULL
);
2334 Tcl_CreateObjCommand (interp
, "gdb_set_bp", call_obj_wrapper
, gdb_set_bp
, NULL
);
2335 Tcl_CreateObjCommand (interp
, "gdb_get_trace_frame_num",
2336 call_obj_wrapper
, gdb_get_trace_frame_num
, NULL
);
2338 command_loop_hook
= tk_command_loop
;
2339 print_frame_info_listing_hook
= gdbtk_print_frame_info
;
2340 query_hook
= gdbtk_query
;
2341 warning_hook
= gdbtk_warning
;
2342 flush_hook
= gdbtk_flush
;
2343 create_breakpoint_hook
= gdbtk_create_breakpoint
;
2344 delete_breakpoint_hook
= gdbtk_delete_breakpoint
;
2345 modify_breakpoint_hook
= gdbtk_modify_breakpoint
;
2346 interactive_hook
= gdbtk_interactive
;
2347 target_wait_hook
= gdbtk_wait
;
2348 call_command_hook
= gdbtk_call_command
;
2349 readline_begin_hook
= gdbtk_readline_begin
;
2350 readline_hook
= gdbtk_readline
;
2351 readline_end_hook
= gdbtk_readline_end
;
2352 ui_load_progress_hook
= gdbtk_load_hash
;
2354 ui_loop_hook
= x_event
;
2356 pre_add_symbol_hook
= gdbtk_pre_add_symbol
;
2357 post_add_symbol_hook
= gdbtk_post_add_symbol
;
2358 create_tracepoint_hook
= gdbtk_create_tracepoint
;
2359 delete_tracepoint_hook
= gdbtk_delete_tracepoint
;
2360 modify_tracepoint_hook
= gdbtk_modify_tracepoint
;
2361 pc_changed_hook
= pc_changed
;
2363 add_com ("tk", class_obscure
, tk_command
,
2364 "Send a command directly into tk.");
2366 Tcl_LinkVar (interp
, "disassemble-from-exec", (char *)&disassemble_from_exec
,
2369 /* find the gdb tcl library and source main.tcl */
2371 gdbtk_lib
= getenv ("GDBTK_LIBRARY");
2373 if (access ("gdbtcl/main.tcl", R_OK
) == 0)
2374 gdbtk_lib
= "gdbtcl";
2376 gdbtk_lib
= GDBTK_LIBRARY
;
2378 gdbtk_lib_tmp
= xstrdup (gdbtk_lib
);
2381 /* see if GDBTK_LIBRARY is a path list */
2382 lib
= strtok (gdbtk_lib_tmp
, GDBTK_PATH_SEP
);
2383 auto_path_elem
= Tcl_NewObj ();
2384 auto_path_name
= Tcl_NewStringObj ("auto_path", -1);
2388 Tcl_SetStringObj (auto_path_elem
, lib
, -1);
2389 if (Tcl_ObjSetVar2 (interp
, auto_path_name
, NULL
, auto_path_elem
,
2390 TCL_GLOBAL_ONLY
| TCL_LIST_ELEMENT
) == NULL
)
2392 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2397 gdbtk_file
= concat (lib
, "/main.tcl", (char *) NULL
);
2398 if (access (gdbtk_file
, R_OK
) == 0)
2401 Tcl_SetVar (interp
, "GDBTK_LIBRARY", lib
, 0);
2405 while ((lib
= strtok (NULL
, ":")) != NULL
);
2407 free (gdbtk_lib_tmp
);
2408 Tcl_DecrRefCount(auto_path_elem
);
2409 Tcl_DecrRefCount(auto_path_name
);
2413 /* Try finding it with the auto path. */
2415 static const char script
[] ="\
2416 proc gdbtk_find_main {} {\n\
2417 global auto_path GDBTK_LIBRARY\n\
2418 foreach dir $auto_path {\n\
2419 set f [file join $dir main.tcl]\n\
2420 if {[file exists $f]} then {\n\
2421 set GDBTK_LIBRARY $dir\n\
2429 if (Tcl_GlobalEval (interp
, (char *) script
) != TCL_OK
)
2431 fputs_unfiltered (Tcl_GetVar (interp
, "errorInfo", 0), gdb_stderr
);
2435 if (interp
->result
[0] != '\0')
2437 gdbtk_file
= xstrdup (interp
->result
);
2444 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2445 if (getenv("GDBTK_LIBRARY"))
2447 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
2448 fprintf_unfiltered (stderr
,
2449 "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
2453 fprintf_unfiltered (stderr
, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY
);
2454 fprintf_unfiltered (stderr
, "You might want to set GDBTK_LIBRARY\n");
2459 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
2460 prior to this point go to stdout/stderr. */
2462 fputs_unfiltered_hook
= gdbtk_fputs
;
2464 /* start-sanitize-tclpro */
2465 #ifdef TCLPRO_DEBUGGER
2467 Tcl_DString source_cmd
;
2469 Tcl_DStringInit (&source_cmd
);
2470 Tcl_DStringAppend (&source_cmd
,
2471 "if {[info exists env(TCLPRO_DEBUG_DIR)]} {source [file join $env(TCLPRO_DEBUG_DIR) src loader.tcl];", -1);
2472 Tcl_DStringAppend (&source_cmd
, "debugger_init; debugger_eval {source {", -1);
2473 Tcl_DStringAppend (&source_cmd
, gdbtk_file
, -1);
2474 Tcl_DStringAppend (&source_cmd
, "}}} else {source {", -1);
2475 Tcl_DStringAppend (&source_cmd
, gdbtk_file
, -1);
2476 Tcl_DStringAppend (&source_cmd
, "}}", -1);
2477 if (Tcl_GlobalEval (interp
, Tcl_DStringValue (&source_cmd
)) != TCL_OK
)
2479 /* end-sanitize-tclpro */
2480 if (Tcl_EvalFile (interp
, gdbtk_file
) != TCL_OK
)
2481 /* start-sanitize-tclpro */
2483 /* end-sanitize-tclpro */
2487 /* Force errorInfo to be set up propertly. */
2488 Tcl_AddErrorInfo (interp
, "");
2490 msg
= Tcl_GetVar (interp
, "errorInfo", TCL_GLOBAL_ONLY
);
2492 fputs_unfiltered_hook
= NULL
; /* Force errors to stdout/stderr */
2495 MessageBox (NULL
, msg
, NULL
, MB_OK
| MB_ICONERROR
| MB_TASKMODAL
);
2497 fputs_unfiltered (msg
, gdb_stderr
);
2502 /* start-sanitize-tclpro */
2503 #ifdef TCLPRO_DEBUGGER
2504 Tcl_DStringFree(&source_cmd
);
2507 /* end-sanitize-tclpro */
2510 /* start-sanitize-ide */
2511 /* Don't do this until we have initialized. Otherwise, we may get a
2512 run command before we are ready for one. */
2513 if (ide_run_server_init (interp
, h
) != TCL_OK
)
2514 error ("ide_run_server_init failed: %s", interp
->result
);
2515 /* end-sanitize-ide */
2520 discard_cleanups (old_chain
);
2524 gdb_target_has_execution_command (clientData
, interp
, argc
, argv
)
2525 ClientData clientData
;
2532 if (target_has_execution
&& inferior_pid
!= 0)
2535 Tcl_SetIntObj (Tcl_GetObjResult (interp
), result
);
2540 gdb_trace_status (clientData
, interp
, argc
, argv
)
2541 ClientData clientData
;
2548 if (trace_running_p
)
2551 Tcl_SetIntObj (Tcl_GetObjResult (interp
), result
);
2555 /* gdb_load_info - returns information about the file about to be downloaded */
2558 gdb_load_info (clientData
, interp
, objc
, objv
)
2559 ClientData clientData
;
2562 Tcl_Obj
*CONST objv
[];
2565 struct cleanup
*old_cleanups
;
2571 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
2573 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
2574 if (loadfile_bfd
== NULL
)
2576 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Open failed", -1));
2579 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
2581 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
2583 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("Bad Object File", -1));
2587 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
2589 if (s
->flags
& SEC_LOAD
)
2591 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
2594 ob
[0] = Tcl_NewStringObj((char *)bfd_get_section_name(loadfile_bfd
, s
), -1);
2595 ob
[1] = Tcl_NewLongObj ((long)size
);
2596 res
[i
++] = Tcl_NewListObj (2, ob
);
2601 Tcl_SetObjResult (interp
, Tcl_NewListObj (i
, res
));
2602 do_cleanups (old_cleanups
);
2608 gdbtk_load_hash (section
, num
)
2613 sprintf (buf
, "download_hash %s %ld", section
, num
);
2614 Tcl_Eval (interp
, buf
);
2615 return atoi (interp
->result
);
2619 * This and gdb_get_locals just call gdb_get_vars_command with the right
2620 * value of clientData. We can't use the client data in the definition
2621 * of the command, because the call wrapper uses this instead...
2625 gdb_get_locals_command (clientData
, interp
, objc
, objv
)
2626 ClientData clientData
;
2629 Tcl_Obj
*CONST objv
[];
2632 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
2637 gdb_get_args_command (clientData
, interp
, objc
, objv
)
2638 ClientData clientData
;
2641 Tcl_Obj
*CONST objv
[];
2644 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
2648 /* gdb_get_vars_command -
2650 * Implements the "gdb_get_locals" and "gdb_get_args" tcl commands. This
2651 * function sets the Tcl interpreter's result to a list of variable names
2652 * depending on clientData. If clientData is one, the result is a list of
2653 * arguments; zero returns a list of locals -- all relative to the block
2654 * specified as an argument to the command. Valid commands include
2655 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
2659 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
2660 ClientData clientData
;
2663 Tcl_Obj
*CONST objv
[];
2666 struct symtabs_and_lines sals
;
2668 struct block
*block
;
2669 char **canonical
, *args
;
2670 int i
, nsyms
, arguments
;
2674 Tcl_AppendResult (interp
,
2675 "wrong # of args: should be \"",
2676 Tcl_GetStringFromObj (objv
[0], NULL
),
2677 " function:line|function|line|*addr\"");
2681 arguments
= (int) clientData
;
2682 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2683 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2684 if (sals
.nelts
== 0)
2686 Tcl_AppendResult (interp
,
2687 "error decoding line", NULL
);
2691 /* Initialize a list that will hold the results */
2692 result
= Tcl_NewListObj (0, NULL
);
2694 /* Resolve all line numbers to PC's */
2695 for (i
= 0; i
< sals
.nelts
; i
++)
2696 resolve_sal_pc (&sals
.sals
[i
]);
2698 block
= block_for_pc (sals
.sals
[0].pc
);
2701 nsyms
= BLOCK_NSYMS (block
);
2702 for (i
= 0; i
< nsyms
; i
++)
2704 sym
= BLOCK_SYM (block
, i
);
2705 switch (SYMBOL_CLASS (sym
)) {
2707 case LOC_UNDEF
: /* catches errors */
2708 case LOC_CONST
: /* constant */
2709 case LOC_TYPEDEF
: /* local typedef */
2710 case LOC_LABEL
: /* local label */
2711 case LOC_BLOCK
: /* local function */
2712 case LOC_CONST_BYTES
: /* loc. byte seq. */
2713 case LOC_UNRESOLVED
: /* unresolved static */
2714 case LOC_OPTIMIZED_OUT
: /* optimized out */
2716 case LOC_ARG
: /* argument */
2717 case LOC_REF_ARG
: /* reference arg */
2718 case LOC_REGPARM
: /* register arg */
2719 case LOC_REGPARM_ADDR
: /* indirect register arg */
2720 case LOC_LOCAL_ARG
: /* stack arg */
2721 case LOC_BASEREG_ARG
: /* basereg arg */
2723 Tcl_ListObjAppendElement (interp
, result
,
2724 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2726 case LOC_LOCAL
: /* stack local */
2727 case LOC_STATIC
: /* static */
2728 case LOC_REGISTER
: /* register */
2729 case LOC_BASEREG
: /* basereg local */
2731 Tcl_ListObjAppendElement (interp
, result
,
2732 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2736 if (BLOCK_FUNCTION (block
))
2739 block
= BLOCK_SUPERBLOCK (block
);
2742 Tcl_SetObjResult (interp
, result
);
2747 gdb_get_line_command (clientData
, interp
, objc
, objv
)
2748 ClientData clientData
;
2751 Tcl_Obj
*CONST objv
[];
2754 struct symtabs_and_lines sals
;
2755 char *args
, **canonical
;
2759 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2760 Tcl_GetStringFromObj (objv
[0], NULL
),
2765 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2766 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2767 if (sals
.nelts
== 1)
2769 Tcl_SetObjResult (interp
, Tcl_NewIntObj (sals
.sals
[0].line
));
2773 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2779 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
2780 ClientData clientData
;
2783 Tcl_Obj
*CONST objv
[];
2787 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2788 Tcl_GetStringFromObj (objv
[0], NULL
),
2793 Tcl_SetObjResult (interp
, Tcl_NewIntObj (get_traceframe_number ()));
2800 gdb_get_file_command (clientData
, interp
, objc
, objv
)
2801 ClientData clientData
;
2804 Tcl_Obj
*CONST objv
[];
2807 struct symtabs_and_lines sals
;
2808 char *args
, **canonical
;
2812 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2813 Tcl_GetStringFromObj (objv
[0], NULL
),
2818 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2819 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2820 if (sals
.nelts
== 1)
2822 Tcl_SetResult (interp
, sals
.sals
[0].symtab
->filename
, TCL_VOLATILE
);
2826 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2831 gdb_get_function_command (clientData
, interp
, objc
, objv
)
2832 ClientData clientData
;
2835 Tcl_Obj
*CONST objv
[];
2839 struct symtabs_and_lines sals
;
2840 char *args
, **canonical
;
2844 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
2845 Tcl_GetStringFromObj (objv
[0], NULL
),
2850 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
2851 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
2852 if (sals
.nelts
== 1)
2854 resolve_sal_pc (&sals
.sals
[0]);
2855 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
2856 if (function
!= NULL
)
2858 Tcl_SetResult (interp
, function
, TCL_VOLATILE
);
2863 Tcl_SetResult (interp
, "N/A", TCL_STATIC
);
2868 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
2869 ClientData clientData
;
2872 Tcl_Obj
*CONST objv
[];
2874 struct symtab_and_line sal
;
2876 struct tracepoint
*tp
;
2877 struct action_line
*al
;
2878 Tcl_Obj
*list
, *action_list
;
2879 char *filename
, *funcname
;
2883 error ("wrong # args");
2885 Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
);
2887 ALL_TRACEPOINTS (tp
)
2888 if (tp
->number
== tpnum
)
2892 error ("Tracepoint #%d does not exist", tpnum
);
2894 list
= Tcl_NewListObj (0, NULL
);
2895 sal
= find_pc_line (tp
->address
, 0);
2896 filename
= symtab_to_filename (sal
.symtab
);
2897 if (filename
== NULL
)
2899 Tcl_ListObjAppendElement (interp
, list
,
2900 Tcl_NewStringObj (filename
, -1));
2901 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
2902 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (funcname
, -1));
2903 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (sal
.line
));
2904 sprintf (tmp
, "0x%lx", tp
->address
);
2905 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewStringObj (tmp
, -1));
2906 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->enabled
));
2907 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->pass_count
));
2908 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->step_count
));
2909 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->thread
));
2910 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->hit_count
));
2912 /* Append a list of actions */
2913 action_list
= Tcl_NewListObj (0, NULL
);
2914 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
2916 Tcl_ListObjAppendElement (interp
, action_list
,
2917 Tcl_NewStringObj (al
->action
, -1));
2919 Tcl_ListObjAppendElement (interp
, list
, action_list
);
2921 Tcl_SetObjResult (interp
, list
);
2926 /* TclDebug (const char *fmt, ...) works just like printf() but */
2927 /* sends the output to the GDB TK debug window. */
2928 /* Not for normal use; just a convenient tool for debugging */
2930 #ifdef ANSI_PROTOTYPES
2931 TclDebug (const char *fmt
, ...)
2938 char buf
[512], *v
[2], *merge
;
2940 #ifdef ANSI_PROTOTYPES
2941 va_start (args
, fmt
);
2945 fmt
= va_arg (args
, char *);
2951 vsprintf (buf
, fmt
, args
);
2954 merge
= Tcl_Merge (2, v
);
2955 Tcl_Eval (interp
, merge
);
2960 /* Find the full pathname to a file, searching the symbol tables */
2963 gdb_find_file_command (clientData
, interp
, objc
, objv
)
2964 ClientData clientData
;
2967 Tcl_Obj
*CONST objv
[];
2969 char *filename
= NULL
;
2974 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
2978 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
2980 filename
= st
->fullname
;
2982 if (filename
== NULL
)
2983 Tcl_SetObjResult (interp
, Tcl_NewStringObj ("", 0));
2985 Tcl_SetObjResult (interp
, Tcl_NewStringObj (filename
, -1));
2991 gdbtk_create_tracepoint (tp
)
2992 struct tracepoint
*tp
;
2994 tracepoint_notify (tp
, "create");
2998 gdbtk_delete_tracepoint (tp
)
2999 struct tracepoint
*tp
;
3001 tracepoint_notify (tp
, "delete");
3005 gdbtk_modify_tracepoint (tp
)
3006 struct tracepoint
*tp
;
3008 tracepoint_notify (tp
, "modify");
3012 tracepoint_notify(tp
, action
)
3013 struct tracepoint
*tp
;
3018 struct symtab_and_line sal
;
3021 /* We ensure that ACTION contains no special Tcl characters, so we
3023 sal
= find_pc_line (tp
->address
, 0);
3025 filename
= symtab_to_filename (sal
.symtab
);
3026 if (filename
== NULL
)
3028 sprintf (buf
, "gdbtk_tcl_tracepoint %s %d 0x%lx %d {%s}", action
, tp
->number
,
3029 (long)tp
->address
, sal
.line
, filename
, tp
->pass_count
);
3031 v
= Tcl_Eval (interp
, buf
);
3035 gdbtk_fputs (interp
->result
, gdb_stdout
);
3036 gdbtk_fputs ("\n", gdb_stdout
);
3040 /* returns -1 if not found, tracepoint # if found */
3042 tracepoint_exists (char * args
)
3044 struct tracepoint
*tp
;
3046 struct symtabs_and_lines sals
;
3050 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
3051 if (sals
.nelts
== 1)
3053 resolve_sal_pc (&sals
.sals
[0]);
3054 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
3055 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
3058 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
3059 strcat (file
, sals
.sals
[0].symtab
->filename
);
3061 ALL_TRACEPOINTS (tp
)
3063 if (tp
->address
== sals
.sals
[0].pc
)
3064 result
= tp
->number
;
3066 /* Why is this here? This messes up assembly traces */
3067 else if (tp
->source_file
!= NULL
3068 && strcmp (tp
->source_file
, file
) == 0
3069 && sals
.sals
[0].line
== tp
->line_number
)
3070 result
= tp
->number
;
3081 gdb_actions_command (clientData
, interp
, objc
, objv
)
3082 ClientData clientData
;
3085 Tcl_Obj
*CONST objv
[];
3087 struct tracepoint
*tp
;
3089 int nactions
, i
, len
;
3090 char *number
, *args
, *action
;
3092 struct action_line
*next
= NULL
, *temp
;
3093 enum actionline_type linetype
;
3097 Tcl_AppendResult (interp
, "wrong # args: should be: \"",
3098 Tcl_GetStringFromObj (objv
[0], NULL
),
3099 " number actions\"");
3103 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
3104 tp
= get_tracepoint_by_number (&args
);
3107 Tcl_AppendResult (interp
, "Tracepoint \"", number
, "\" does not exist");
3111 /* Free any existing actions */
3112 if (tp
->actions
!= NULL
)
3117 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
3119 /* Add the actions to the tracepoint */
3120 for (i
= 0; i
< nactions
; i
++)
3122 temp
= xmalloc (sizeof (struct action_line
));
3124 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
3125 temp
->action
= savestring (action
, len
);
3127 linetype
= validate_actionline (&(temp
->action
), tp
);
3129 if (linetype
== BADLINE
)
3151 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
3152 ClientData clientData
;
3155 Tcl_Obj
*CONST objv
[];
3161 Tcl_AppendResult (interp
, "wrong # of args: should be \"",
3162 Tcl_GetStringFromObj (objv
[0], NULL
),
3163 " function:line|function|line|*addr\"");
3167 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
3169 Tcl_SetObjResult (interp
, Tcl_NewIntObj (tracepoint_exists (args
)));
3173 /* Return the prompt to the interpreter */
3175 gdb_prompt_command (clientData
, interp
, objc
, objv
)
3176 ClientData clientData
;
3179 Tcl_Obj
*CONST objv
[];
3181 Tcl_SetResult (interp
, get_prompt (), TCL_VOLATILE
);
3185 /* return a list of all tracepoint numbers in interpreter */
3187 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
3188 ClientData clientData
;
3191 Tcl_Obj
*CONST objv
[];
3194 struct tracepoint
*tp
;
3196 list
= Tcl_NewListObj (0, NULL
);
3198 ALL_TRACEPOINTS (tp
)
3199 Tcl_ListObjAppendElement (interp
, list
, Tcl_NewIntObj (tp
->number
));
3201 Tcl_SetObjResult (interp
, list
);
3206 /* This hook is called whenever we are ready to load a symbol file so that
3207 the UI can notify the user... */
3209 gdbtk_pre_add_symbol (name
)
3214 v
[0] = "gdbtk_tcl_pre_add_symbol";
3216 merge
= Tcl_Merge (2, v
);
3217 Tcl_Eval (interp
, merge
);
3221 /* This hook is called whenever we finish loading a symbol file. */
3223 gdbtk_post_add_symbol ()
3225 Tcl_Eval (interp
, "gdbtk_tcl_post_add_symbol");
3231 gdbtk_print_frame_info (s
, line
, stopline
, noerror
)
3237 current_source_symtab
= s
;
3238 current_source_line
= line
;
3242 /* The lookup_symtab() in symtab.c doesn't work correctly */
3243 /* It will not work will full pathnames and if multiple */
3244 /* source files have the same basename, it will return */
3245 /* the first one instead of the correct one. This version */
3246 /* also always makes sure symtab->fullname is set. */
3248 static struct symtab
*
3249 full_lookup_symtab(file
)
3253 struct objfile
*objfile
;
3254 char *bfile
, *fullname
;
3255 struct partial_symtab
*pt
;
3260 /* first try a direct lookup */
3261 st
= lookup_symtab (file
);
3265 symtab_to_filename(st
);
3269 /* if the direct approach failed, try */
3270 /* looking up the basename and checking */
3271 /* all matches with the fullname */
3272 bfile
= basename (file
);
3273 ALL_SYMTABS (objfile
, st
)
3275 if (!strcmp (bfile
, basename(st
->filename
)))
3278 fullname
= symtab_to_filename (st
);
3280 fullname
= st
->fullname
;
3282 if (!strcmp (file
, fullname
))
3287 /* still no luck? look at psymtabs */
3288 ALL_PSYMTABS (objfile
, pt
)
3290 if (!strcmp (bfile
, basename(pt
->filename
)))
3292 st
= PSYMTAB_TO_SYMTAB (pt
);
3295 fullname
= symtab_to_filename (st
);
3296 if (!strcmp (file
, fullname
))
3305 perror_with_name_wrapper (args
)
3308 perror_with_name (args
);
3312 /* gdb_loadfile loads a c source file into a text widget. */
3314 /* LTABLE_SIZE is the number of bytes to allocate for the */
3315 /* line table. Its size limits the maximum number of lines */
3316 /* in a file to 8 * LTABLE_SIZE. This memory is freed after */
3317 /* the file is loaded, so it is OK to make this very large. */
3318 /* Additional memory will be allocated if needed. */
3319 #define LTABLE_SIZE 20000
3322 gdb_loadfile (clientData
, interp
, objc
, objv
)
3323 ClientData clientData
;
3326 Tcl_Obj
*CONST objv
[];
3328 char *file
, *widget
, *line
, *buf
, msg
[128];
3329 int linenumbers
, ln
, anum
, lnum
, ltable_size
;
3330 Tcl_Obj
*a
[2], *b
[2], *cmd
;
3333 struct symtab
*symtab
;
3334 struct linetable_entry
*le
;
3341 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
3345 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
3346 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
3347 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
3349 if ((fp
= fopen ( file
, "r" )) == NULL
)
3352 symtab
= full_lookup_symtab (file
);
3355 sprintf(msg
, "File not found");
3356 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3361 if (stat (file
, &st
) < 0)
3363 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
3368 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
3369 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
3371 mtime
= bfd_get_mtime(exec_bfd
);
3373 if (mtime
&& mtime
< st
.st_mtime
)
3374 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
3377 /* Source linenumbers don't appear to be in order, and a sort is */
3378 /* too slow so the fastest solution is just to allocate a huge */
3379 /* array and set the array entry for each linenumber */
3381 ltable_size
= LTABLE_SIZE
;
3382 ltable
= (char *)malloc (LTABLE_SIZE
);
3385 sprintf(msg
, "Out of memory.");
3386 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3391 memset (ltable
, 0, LTABLE_SIZE
);
3393 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
3395 le
= symtab
->linetable
->item
;
3396 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
3398 lnum
= le
->line
>> 3;
3399 if (lnum
>= ltable_size
)
3402 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
3403 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
3405 if (new_ltable
== NULL
)
3407 sprintf(msg
, "Out of memory.");
3408 Tcl_SetStringObj ( Tcl_GetObjResult (interp
), msg
, -1);
3413 ltable
= new_ltable
;
3415 ltable
[lnum
] |= 1 << (le
->line
% 8);
3419 /* create an object with enough space, then grab its */
3420 /* buffer and sprintf directly into it. */
3421 a
[0] = Tcl_NewStringObj (ltable
, 1024);
3422 a
[1] = Tcl_NewListObj(0,NULL
);
3424 b
[0] = Tcl_NewStringObj (ltable
,1024);
3425 b
[1] = Tcl_NewStringObj ("source_tag", -1);
3426 Tcl_IncrRefCount (b
[0]);
3427 Tcl_IncrRefCount (b
[1]);
3428 line
= b
[0]->bytes
+ 1;
3429 strcpy(b
[0]->bytes
,"\t");
3432 while (fgets (line
, 980, fp
))
3436 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3438 sprintf (buf
,"%s insert end {-\t%d} break_tag", widget
, ln
);
3439 a
[0]->length
= strlen (buf
);
3443 sprintf (buf
,"%s insert end { \t%d} \"\"", widget
, ln
);
3444 a
[0]->length
= strlen (buf
);
3449 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
3451 sprintf (buf
,"%s insert end {-\t} break_tag", widget
);
3452 a
[0]->length
= strlen (buf
);
3456 sprintf (buf
,"%s insert end { \t} \"\"", widget
);
3457 a
[0]->length
= strlen (buf
);
3460 b
[0]->length
= strlen(b
[0]->bytes
);
3461 Tcl_SetListObj(a
[1],2,b
);
3462 cmd
= Tcl_ConcatObj(2,a
);
3463 Tcl_EvalObj (interp
, cmd
);
3464 Tcl_DecrRefCount (cmd
);
3467 Tcl_DecrRefCount (b
[0]);
3468 Tcl_DecrRefCount (b
[0]);
3469 Tcl_DecrRefCount (b
[1]);
3470 Tcl_DecrRefCount (b
[1]);
3476 /* at some point make these static in breakpoint.c and move GUI code there */
3477 extern struct breakpoint
*set_raw_breakpoint (struct symtab_and_line sal
);
3478 extern void set_breakpoint_count (int);
3479 extern int breakpoint_count
;
3481 /* set a breakpoint by source file and line number */
3482 /* flags are as follows: */
3483 /* least significant 2 bits are disposition, rest is */
3484 /* type (normally 0).
3487 bp_breakpoint, Normal breakpoint
3488 bp_hardware_breakpoint, Hardware assisted breakpoint
3491 Disposition of breakpoint. Ie: what to do after hitting it.
3494 del_at_next_stop, Delete at next stop, whether hit or not
3496 donttouch Leave it alone
3501 gdb_set_bp (clientData
, interp
, objc
, objv
)
3502 ClientData clientData
;
3505 Tcl_Obj
*CONST objv
[];
3508 struct symtab_and_line sal
;
3509 int line
, flags
, ret
;
3510 struct breakpoint
*b
;
3512 Tcl_Obj
*a
[5], *cmd
;
3516 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
3520 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
3521 if (sal
.symtab
== NULL
)
3524 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
3527 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
3531 sal
.pc
= find_line_pc (sal
.symtab
, sal
.line
);
3535 sal
.section
= find_pc_overlay (sal
.pc
);
3536 b
= set_raw_breakpoint (sal
);
3537 set_breakpoint_count (breakpoint_count
+ 1);
3538 b
->number
= breakpoint_count
;
3539 b
->type
= flags
>> 2;
3540 b
->disposition
= flags
& 3;
3542 /* FIXME: this won't work for duplicate basenames! */
3543 sprintf (buf
, "%s:%d", basename(Tcl_GetStringFromObj( objv
[1], NULL
)), line
);
3544 b
->addr_string
= strsave (buf
);
3546 /* now send notification command back to GUI */
3547 sprintf (buf
, "0x%x", sal
.pc
);
3548 a
[0] = Tcl_NewStringObj ("gdbtk_tcl_breakpoint create", -1);
3549 a
[1] = Tcl_NewIntObj (b
->number
);
3550 a
[2] = Tcl_NewStringObj (buf
, -1);
3552 a
[4] = Tcl_NewListObj (1,&objv
[1]);
3553 cmd
= Tcl_ConcatObj(5,a
);
3554 ret
= Tcl_EvalObj (interp
, cmd
);
3555 Tcl_DecrRefCount (cmd
);
3559 /* Come here during initialize_all_files () */
3562 _initialize_gdbtk ()
3566 /* Tell the rest of the world that Gdbtk is now set up. */
3568 init_ui_hook
= gdbtk_init
;
3570 (void) FreeConsole ();
3576 DWORD ft
= GetFileType (GetStdHandle (STD_INPUT_HANDLE
));
3577 void cygwin32_attach_handle_to_fd (char *, int, HANDLE
, int, int);
3581 case FILE_TYPE_DISK
:
3582 case FILE_TYPE_CHAR
:
3583 case FILE_TYPE_PIPE
:
3587 cygwin32_attach_handle_to_fd ("/dev/conin", 0,
3588 GetStdHandle (STD_INPUT_HANDLE
),
3590 cygwin32_attach_handle_to_fd ("/dev/conout", 1,
3591 GetStdHandle (STD_OUTPUT_HANDLE
),
3593 cygwin32_attach_handle_to_fd ("/dev/conout", 2,
3594 GetStdHandle (STD_ERROR_HANDLE
),