1 /* Tcl/Tk command definitions for gdbtk.
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"
48 /* start-sanitize-ide */
52 /* end-sanitize-ide */
55 #ifdef ANSI_PROTOTYPES
65 #include <sys/ioctl.h>
66 #include "gdb_string.h"
74 /* This structure filled in call_wrapper and passed to
75 the wrapped call function.
76 It stores the command pointer and arguments
77 run in the wrapper function. */
79 struct wrapped_call_args
88 /* These two objects hold boolean true and false,
89 and are shared by all the list objects that gdb_listfuncs
92 static Tcl_Obj
*mangled
, *not_mangled
;
94 /* These two control how the GUI behaves when gdb is either tracing or loading.
95 They are used in this file & gdbtk_hooks.c */
98 int load_in_progress
= 0;
101 * This is used in the register fetching routines
104 #ifndef REGISTER_CONVERTIBLE
105 #define REGISTER_CONVERTIBLE(x) (0 != 0)
108 #ifndef REGISTER_CONVERT_TO_VIRTUAL
109 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
112 #ifndef INVALID_FLOAT
113 #define INVALID_FLOAT(x, y) (0 != 0)
118 /* This Structure is used in gdb_disassemble.
119 We need a different sort of line table from the normal one cuz we can't
120 depend upon implicit line-end pc's for lines to do the
121 reordering in this function. */
123 struct my_line_entry
{
129 /* This contains the previous values of the registers, since the last call to
130 gdb_changed_register_list. */
132 static char old_regs
[REGISTER_BYTES
];
135 * These are routines we need from breakpoint.c.
136 * at some point make these static in breakpoint.c and move GUI code there
139 extern struct breakpoint
*set_raw_breakpoint (struct symtab_and_line sal
);
140 extern void set_breakpoint_count (int);
141 extern int breakpoint_count
;
145 * Declarations for routines used only in this file.
148 int Gdbtk_Init (Tcl_Interp
*interp
);
149 static int compare_lines
PARAMS ((const PTR
, const PTR
));
150 static int comp_files
PARAMS ((const void *, const void *));
151 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
152 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
153 Tcl_Obj
*CONST objv
[]));
154 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
155 static int gdb_clear_file
PARAMS ((ClientData
, Tcl_Interp
*interp
, int, Tcl_Obj
*CONST
[]));
156 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
157 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
158 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int,
160 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
161 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
162 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
163 Tcl_Obj
*CONST objv
[]));
164 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
165 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
166 static int gdb_get_args_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
167 Tcl_Obj
*CONST objv
[]));
168 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
169 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
170 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
171 Tcl_Obj
*CONST objv
[]));
172 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
173 Tcl_Obj
*CONST objv
[]));
174 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
175 Tcl_Obj
*CONST objv
[]));
176 static int gdb_get_locals_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
177 Tcl_Obj
*CONST objv
[]));
178 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
179 static int gdb_get_trace_frame_num
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
180 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int,
181 Tcl_Obj
*CONST objv
[]));
182 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
183 Tcl_Obj
*CONST objv
[]));
184 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
185 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
186 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
187 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
188 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
189 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
190 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
191 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
192 Tcl_Obj
*CONST objv
[]));
193 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
194 static int gdb_search
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
196 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
197 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
198 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*,
201 static int gdb_trace_status
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
202 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*,
204 Tcl_Obj
*CONST objv
[]));
205 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int,
206 Tcl_Obj
*CONST objv
[]));
207 static void gdbtk_create_breakpoint
PARAMS ((struct breakpoint
*));
208 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
209 static void gdbtk_create_tracepoint
PARAMS ((struct tracepoint
*));
210 static void gdbtk_delete_breakpoint
PARAMS ((struct breakpoint
*));
211 static void gdbtk_delete_tracepoint
PARAMS ((struct tracepoint
*));
212 static void gdbtk_modify_breakpoint
PARAMS ((struct breakpoint
*));
213 static void gdbtk_modify_tracepoint
PARAMS ((struct tracepoint
*));
214 static void gdbtk_print_frame_info
PARAMS ((struct symtab
*, int, int, int));
215 static void gdbtk_readline_end
PARAMS ((void));
216 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
217 char * get_prompt
PARAMS ((void));
218 static void get_register
PARAMS ((int, void *));
219 static void get_register_name
PARAMS ((int, void *));
220 static int map_arg_registers
PARAMS ((int, Tcl_Obj
*CONST
[], void (*) (int, void *), void *));
221 static void pc_changed
PARAMS ((void));
222 static int perror_with_name_wrapper
PARAMS ((char *args
));
223 static void register_changed_p
PARAMS ((int, void *));
224 void TclDebug
PARAMS ((const char *fmt
, ...));
225 static int wrapped_call (char *opaque_args
);
228 * This loads all the Tcl commands into the Tcl interpreter.
231 * interp - The interpreter into which to load the commands.
234 * A standard Tcl result.
241 Tcl_CreateObjCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
242 Tcl_CreateObjCommand (interp
, "gdb_immediate", call_wrapper
,
243 gdb_immediate_command
, NULL
);
244 Tcl_CreateObjCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
245 Tcl_CreateObjCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
246 Tcl_CreateObjCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
, NULL
);
247 Tcl_CreateObjCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
249 Tcl_CreateObjCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
251 Tcl_CreateObjCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
252 Tcl_CreateObjCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
253 Tcl_CreateObjCommand (interp
, "gdb_fetch_registers", call_wrapper
,
254 gdb_fetch_registers
, NULL
);
255 Tcl_CreateObjCommand (interp
, "gdb_changed_register_list", call_wrapper
,
256 gdb_changed_register_list
, NULL
);
257 Tcl_CreateObjCommand (interp
, "gdb_disassemble", call_wrapper
,
258 gdb_disassemble
, NULL
);
259 Tcl_CreateObjCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
260 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
261 gdb_get_breakpoint_list
, NULL
);
262 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
263 gdb_get_breakpoint_info
, NULL
);
264 Tcl_CreateObjCommand (interp
, "gdb_clear_file", call_wrapper
,
265 gdb_clear_file
, NULL
);
266 Tcl_CreateObjCommand (interp
, "gdb_confirm_quit", call_wrapper
,
267 gdb_confirm_quit
, NULL
);
268 Tcl_CreateObjCommand (interp
, "gdb_force_quit", call_wrapper
,
269 gdb_force_quit
, NULL
);
270 Tcl_CreateObjCommand (interp
, "gdb_target_has_execution",
272 gdb_target_has_execution_command
, NULL
);
273 Tcl_CreateObjCommand (interp
, "gdb_is_tracing",
274 call_wrapper
, gdb_trace_status
,
276 Tcl_CreateObjCommand (interp
, "gdb_load_info", call_wrapper
, gdb_load_info
, NULL
);
277 Tcl_CreateObjCommand (interp
, "gdb_get_locals", call_wrapper
, gdb_get_locals_command
,
279 Tcl_CreateObjCommand (interp
, "gdb_get_args", call_wrapper
, gdb_get_args_command
,
281 Tcl_CreateObjCommand (interp
, "gdb_get_function", call_wrapper
, gdb_get_function_command
,
283 Tcl_CreateObjCommand (interp
, "gdb_get_line", call_wrapper
, gdb_get_line_command
,
285 Tcl_CreateObjCommand (interp
, "gdb_get_file", call_wrapper
, gdb_get_file_command
,
287 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
288 call_wrapper
, gdb_tracepoint_exists_command
, NULL
);
289 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
290 call_wrapper
, gdb_get_tracepoint_info
, NULL
);
291 Tcl_CreateObjCommand (interp
, "gdb_actions",
292 call_wrapper
, gdb_actions_command
, NULL
);
293 Tcl_CreateObjCommand (interp
, "gdb_prompt",
294 call_wrapper
, gdb_prompt_command
, NULL
);
295 Tcl_CreateObjCommand (interp
, "gdb_find_file",
296 call_wrapper
, gdb_find_file_command
, NULL
);
297 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
298 call_wrapper
, gdb_get_tracepoint_list
, NULL
);
299 Tcl_CreateObjCommand (interp
, "gdb_pc_reg", call_wrapper
, get_pc_register
, NULL
);
300 Tcl_CreateObjCommand (interp
, "gdb_loadfile", call_wrapper
, gdb_loadfile
, NULL
);
301 Tcl_CreateObjCommand (gdbtk_interp
, "gdb_search", call_wrapper
,
303 Tcl_CreateObjCommand (interp
, "gdb_set_bp", call_wrapper
, gdb_set_bp
, NULL
);
304 Tcl_CreateObjCommand (interp
, "gdb_get_trace_frame_num",
305 call_wrapper
, gdb_get_trace_frame_num
, NULL
);
307 Tcl_PkgProvide(interp
, "Gdbtk", GDBTK_VERSION
);
311 /* This routine acts as a top-level for all GDB code called by Tcl/Tk. It
312 handles cleanups, and uses catch_errors to trap calls to return_to_top_level
314 This is necessary in order to prevent a longjmp out of the bowels of Tk,
315 possibly leaving things in a bad state. Since this routine can be called
316 recursively, it needs to save and restore the contents of the result_ptr as
320 call_wrapper (clientData
, interp
, objc
, objv
)
321 ClientData clientData
;
324 Tcl_Obj
*CONST objv
[];
326 struct wrapped_call_args wrapped_args
;
327 gdbtk_result new_result
, *old_result_ptr
;
330 old_result_ptr
= result_ptr
;
331 result_ptr
= &new_result
;
332 result_ptr
->obj_ptr
= Tcl_NewObj();
333 result_ptr
->flags
= GDBTK_TO_RESULT
;
335 wrapped_args
.func
= (Tcl_ObjCmdProc
*) clientData
;
336 wrapped_args
.interp
= interp
;
337 wrapped_args
.objc
= objc
;
338 wrapped_args
.objv
= objv
;
339 wrapped_args
.val
= TCL_OK
;
341 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
344 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
346 /* Make sure the timer interrupts are turned off. */
350 gdb_flush (gdb_stderr
); /* Flush error output */
351 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
353 /* If we errored out here, and the results were going to the
354 console, then gdbtk_fputs will have gathered the result into the
355 result_ptr. We also need to echo them out to the console here */
357 gdb_flush (gdb_stderr
); /* Flush error output */
358 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
360 /* In case of an error, we may need to force the GUI into idle
361 mode because gdbtk_call_command may have bombed out while in
362 the command routine. */
365 Tcl_Eval (interp
, "gdbtk_tcl_idle");
369 /* do not suppress any errors -- a remote target could have errored */
370 load_in_progress
= 0;
373 * Now copy the result over to the true Tcl result. If GDBTK_TO_RESULT flag
374 * bit is set , this just copies a null object over to the Tcl result, which is
375 * fine because we should reset the result in this case anyway.
377 if (result_ptr
->flags
& GDBTK_IN_TCL_RESULT
)
379 Tcl_DecrRefCount(result_ptr
->obj_ptr
);
383 Tcl_SetObjResult (interp
, result_ptr
->obj_ptr
);
386 result_ptr
= old_result_ptr
;
392 return wrapped_args
.val
;
396 * This is the wrapper that is passed to catch_errors.
400 wrapped_call (opaque_args
)
403 struct wrapped_call_args
*args
= (struct wrapped_call_args
*) opaque_args
;
404 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->objc
, args
->objv
);
408 /* This is a convenience function to sprintf something(s) into a
409 * new element in a Tcl list object.
413 #ifdef ANSI_PROTOTYPES
414 sprintf_append_element_to_obj (Tcl_Obj
*objp
, char *format
, ...)
416 sprintf_append_element_to_obj (va_alist
)
423 #ifdef ANSI_PROTOTYPES
424 va_start (args
, format
);
430 dsp
= va_arg (args
, Tcl_Obj
*);
431 format
= va_arg (args
, char *);
434 vsprintf (buf
, format
, args
);
436 Tcl_ListObjAppendElement (NULL
, objp
, Tcl_NewStringObj (buf
, -1));
440 * This section contains the commands that control execution.
443 /* This implements the tcl command gdb_clear_file.
445 * Prepare to accept a new executable file. This is called when we
446 * want to clear away everything we know about the old file, without
447 * asking the user. The Tcl code will have already asked the user if
448 * necessary. After this is called, we should be able to run the
449 * `file' command without getting any questions.
458 gdb_clear_file (clientData
, interp
, objc
, objv
)
459 ClientData clientData
;
462 Tcl_Obj
*CONST objv
[];
465 Tcl_SetStringObj (result_ptr
->obj_ptr
,
466 "Wrong number of args, none are allowed.", -1);
468 if (inferior_pid
!= 0 && target_has_execution
)
471 target_detach (NULL
, 0);
476 if (target_has_execution
)
479 symbol_file_command (NULL
, 0);
481 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
482 clear it here. FIXME: This seems like an abstraction violation
489 /* This implements the tcl command gdb_confirm_quit
490 * Ask the user to confirm an exit request.
495 * A boolean, 1 if the user answered yes, 0 if no.
499 gdb_confirm_quit (clientData
, interp
, objc
, objv
)
500 ClientData clientData
;
503 Tcl_Obj
*CONST objv
[];
509 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
513 ret
= quit_confirm ();
514 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, ret
);
518 /* This implements the tcl command gdb_force_quit
519 * Quit without asking for confirmation.
528 gdb_force_quit (clientData
, interp
, objc
, objv
)
529 ClientData clientData
;
532 Tcl_Obj
*CONST objv
[];
536 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
540 quit_force ((char *) NULL
, 1);
544 /* This implements the tcl command gdb_stop
545 * It stops the target in a continuable fashion.
554 gdb_stop (clientData
, interp
, objc
, objv
)
555 ClientData clientData
;
558 Tcl_Obj
*CONST objv
[];
565 quit_flag
= 1; /* hope something sees this */
572 * This section contains Tcl commands that are wrappers for invoking
573 * the GDB command interpreter.
577 /* This implements the tcl command `gdb_eval'.
578 * It uses the gdb evaluator to return the value of
579 * an expression in the current language
582 * expression - the expression to evaluate.
584 * The result of the evaluation.
588 gdb_eval (clientData
, interp
, objc
, objv
)
589 ClientData clientData
;
592 Tcl_Obj
*CONST objv
[];
594 struct expression
*expr
;
595 struct cleanup
*old_chain
;
600 Tcl_SetStringObj (result_ptr
->obj_ptr
,
601 "wrong # args, should be \"gdb_eval expression\"", -1);
605 expr
= parse_expression (Tcl_GetStringFromObj (objv
[1], NULL
));
607 old_chain
= make_cleanup (free_current_contents
, &expr
);
609 val
= evaluate_expression (expr
);
612 * Print the result of the expression evaluation. This will go to
613 * eventually go to gdbtk_fputs, and from there be collected into
617 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
618 gdb_stdout
, 0, 0, 0, 0);
620 do_cleanups (old_chain
);
625 /* This implements the tcl command "gdb_cmd".
627 * It sends its argument to the GDB command scanner for execution.
628 * This command will never cause the update, idle and busy hooks to be called
632 * command - The GDB command to execute
634 * The output from the gdb command (except for the "load" & "while"
635 * which dump their output to the console.
639 gdb_cmd (clientData
, interp
, objc
, objv
)
640 ClientData clientData
;
643 Tcl_Obj
*CONST objv
[];
648 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
652 if (running_now
|| load_in_progress
)
657 /* for the load instruction (and possibly others later) we
658 set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
659 will not buffer all the data until the command is finished. */
661 if ((strncmp ("load ", Tcl_GetStringFromObj (objv
[1], NULL
), 5) == 0)
662 || (strncmp ("while ", Tcl_GetStringFromObj (objv
[1], NULL
), 6) == 0))
664 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
665 load_in_progress
= 1;
666 gdbtk_start_timer ();
669 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
671 if (load_in_progress
)
674 load_in_progress
= 0;
675 result_ptr
->flags
|= GDBTK_TO_RESULT
;
678 bpstat_do_actions (&stop_bpstat
);
684 * This implements the tcl command "gdb_immediate"
686 * It does exactly the same thing as gdb_cmd, except NONE of its outut
687 * is buffered. This will also ALWAYS cause the busy, update, and idle hooks to
688 * be called, contrasted with gdb_cmd, which NEVER calls them.
689 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
690 * to the console window.
693 * command - The GDB command to execute
699 gdb_immediate_command (clientData
, interp
, objc
, objv
)
700 ClientData clientData
;
703 Tcl_Obj
*CONST objv
[];
708 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
712 if (running_now
|| load_in_progress
)
717 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
719 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
721 bpstat_do_actions (&stop_bpstat
);
723 result_ptr
->flags
|= GDBTK_TO_RESULT
;
728 /* This implements the tcl command "gdb_prompt"
730 * It returns the gdb interpreter's prompt.
739 gdb_prompt_command (clientData
, interp
, objc
, objv
)
740 ClientData clientData
;
743 Tcl_Obj
*CONST objv
[];
745 Tcl_SetStringObj (result_ptr
->obj_ptr
, get_prompt (), -1);
751 * This section contains general informational commands.
754 /* This implements the tcl command "gdb_target_has_execution"
756 * Tells whether the target is executing.
761 * A boolean indicating whether the target is executing.
765 gdb_target_has_execution_command (clientData
, interp
, objc
, objv
)
766 ClientData clientData
;
769 Tcl_Obj
*CONST objv
[];
773 if (target_has_execution
&& inferior_pid
!= 0)
776 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, result
);
780 /* This implements the tcl command "gdb_load_info"
782 * It returns information about the file about to be downloaded.
785 * filename: The file to open & get the info on.
787 * A list consisting of the name and size of each section.
791 gdb_load_info (clientData
, interp
, objc
, objv
)
792 ClientData clientData
;
795 Tcl_Obj
*CONST objv
[];
798 struct cleanup
*old_cleanups
;
803 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
805 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
806 if (loadfile_bfd
== NULL
)
808 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Open failed", -1);
811 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
813 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
815 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Bad Object File", -1);
819 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
821 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
823 if (s
->flags
& SEC_LOAD
)
825 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
828 ob
[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd
, s
), -1);
829 ob
[1] = Tcl_NewLongObj ((long) size
);
830 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewListObj (2, ob
));
835 do_cleanups (old_cleanups
);
841 * This and gdb_get_locals just call gdb_get_vars_command with the right
842 * value of clientData. We can't use the client data in the definition
843 * of the command, because the call wrapper uses this instead...
847 gdb_get_locals_command (clientData
, interp
, objc
, objv
)
848 ClientData clientData
;
851 Tcl_Obj
*CONST objv
[];
854 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
859 gdb_get_args_command (clientData
, interp
, objc
, objv
)
860 ClientData clientData
;
863 Tcl_Obj
*CONST objv
[];
866 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
870 /* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
872 * This function sets the Tcl interpreter's result to a list of variable names
873 * depending on clientData. If clientData is one, the result is a list of
874 * arguments; zero returns a list of locals -- all relative to the block
875 * specified as an argument to the command. Valid commands include
876 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
880 * block - the address within which to specify the locals or args.
882 * A list of the locals or args
886 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
887 ClientData clientData
;
890 Tcl_Obj
*CONST objv
[];
892 struct symtabs_and_lines sals
;
895 char **canonical
, *args
;
896 int i
, nsyms
, arguments
;
900 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
,
901 "wrong # of args: should be \"",
902 Tcl_GetStringFromObj (objv
[0], NULL
),
903 " function:line|function|line|*addr\"", NULL
);
907 arguments
= (int) clientData
;
908 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
909 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
912 Tcl_SetStringObj (result_ptr
->obj_ptr
,
913 "error decoding line", -1);
917 /* Initialize the result pointer to an empty list. */
919 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
921 /* Resolve all line numbers to PC's */
922 for (i
= 0; i
< sals
.nelts
; i
++)
923 resolve_sal_pc (&sals
.sals
[i
]);
925 block
= block_for_pc (sals
.sals
[0].pc
);
928 nsyms
= BLOCK_NSYMS (block
);
929 for (i
= 0; i
< nsyms
; i
++)
931 sym
= BLOCK_SYM (block
, i
);
932 switch (SYMBOL_CLASS (sym
)) {
934 case LOC_UNDEF
: /* catches errors */
935 case LOC_CONST
: /* constant */
936 case LOC_STATIC
: /* static */
937 case LOC_REGISTER
: /* register */
938 case LOC_TYPEDEF
: /* local typedef */
939 case LOC_LABEL
: /* local label */
940 case LOC_BLOCK
: /* local function */
941 case LOC_CONST_BYTES
: /* loc. byte seq. */
942 case LOC_UNRESOLVED
: /* unresolved static */
943 case LOC_OPTIMIZED_OUT
: /* optimized out */
945 case LOC_ARG
: /* argument */
946 case LOC_REF_ARG
: /* reference arg */
947 case LOC_REGPARM
: /* register arg */
948 case LOC_REGPARM_ADDR
: /* indirect register arg */
949 case LOC_LOCAL_ARG
: /* stack arg */
950 case LOC_BASEREG_ARG
: /* basereg arg */
952 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
953 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
955 case LOC_LOCAL
: /* stack local */
956 case LOC_BASEREG
: /* basereg local */
958 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
959 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
963 if (BLOCK_FUNCTION (block
))
966 block
= BLOCK_SUPERBLOCK (block
);
972 /* This implements the tcl command "gdb_get_line"
974 * It returns the linenumber for a given linespec. It will take any spec
975 * that can be passed to decode_line_1
978 * linespec - the line specification
980 * The line number for that spec.
983 gdb_get_line_command (clientData
, interp
, objc
, objv
)
984 ClientData clientData
;
987 Tcl_Obj
*CONST objv
[];
990 struct symtabs_and_lines sals
;
991 char *args
, **canonical
;
995 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
996 Tcl_GetStringFromObj (objv
[0], NULL
),
997 " linespec\"", NULL
);
1001 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1002 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1003 if (sals
.nelts
== 1)
1005 Tcl_SetIntObj (result_ptr
->obj_ptr
, sals
.sals
[0].line
);
1009 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1014 /* This implements the tcl command "gdb_get_file"
1016 * It returns the file containing a given line spec.
1019 * linespec - The linespec to look up
1021 * The file containing it.
1025 gdb_get_file_command (clientData
, interp
, objc
, objv
)
1026 ClientData clientData
;
1029 Tcl_Obj
*CONST objv
[];
1032 struct symtabs_and_lines sals
;
1033 char *args
, **canonical
;
1037 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1038 Tcl_GetStringFromObj (objv
[0], NULL
),
1039 " linespec\"", NULL
);
1043 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1044 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1045 if (sals
.nelts
== 1)
1047 Tcl_SetStringObj (result_ptr
->obj_ptr
, sals
.sals
[0].symtab
->filename
, -1);
1051 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1055 /* This implements the tcl command "gdb_get_function"
1057 * It finds the function containing the given line spec.
1060 * linespec - The line specification
1062 * The function that contains it, or "N/A" if it is not in a function.
1065 gdb_get_function_command (clientData
, interp
, objc
, objv
)
1066 ClientData clientData
;
1069 Tcl_Obj
*CONST objv
[];
1072 struct symtabs_and_lines sals
;
1073 char *args
, **canonical
;
1077 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1078 Tcl_GetStringFromObj (objv
[0], NULL
),
1079 " linespec\"", NULL
);
1083 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1084 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1085 if (sals
.nelts
== 1)
1087 resolve_sal_pc (&sals
.sals
[0]);
1088 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
1089 if (function
!= NULL
)
1091 Tcl_SetStringObj (result_ptr
->obj_ptr
, function
, -1);
1096 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1100 /* This implements the tcl command "gdb_find_file"
1102 * It searches the symbol tables to get the full pathname to a file.
1105 * filename: the file name to search for.
1107 * The full path to the file, or an empty string if the file is not
1112 gdb_find_file_command (clientData
, interp
, objc
, objv
)
1113 ClientData clientData
;
1116 Tcl_Obj
*CONST objv
[];
1118 char *filename
= NULL
;
1123 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
1127 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1129 filename
= st
->fullname
;
1131 if (filename
== NULL
)
1132 Tcl_SetStringObj (result_ptr
->obj_ptr
, "", 0);
1134 Tcl_SetStringObj (result_ptr
->obj_ptr
, filename
, -1);
1139 /* This implements the tcl command "gdb_listfiles"
1141 * This lists all the files in the current executible.
1143 * Note that this currently pulls in all sorts of filenames
1144 * that aren't really part of the executable. It would be
1145 * best if we could check each file to see if it actually
1146 * contains executable lines of code, but we can't do that
1150 * ?pathname? - If provided, only files which match pathname
1151 * (up to strlen(pathname)) are included. THIS DOES NOT
1152 * CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1153 * THE FULL PATHNAME!!!
1156 * A list of all matching files.
1159 gdb_listfiles (clientData
, interp
, objc
, objv
)
1160 ClientData clientData
;
1163 Tcl_Obj
*CONST objv
[];
1165 struct objfile
*objfile
;
1166 struct partial_symtab
*psymtab
;
1167 struct symtab
*symtab
;
1168 char *lastfile
, *pathname
, **files
;
1170 int i
, numfiles
= 0, len
= 0;
1174 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1178 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1182 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1184 ALL_PSYMTABS (objfile
, psymtab
)
1186 if (numfiles
== files_size
)
1188 files_size
= files_size
* 2;
1189 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1191 if (psymtab
->filename
)
1193 if (!len
|| !strncmp(pathname
, psymtab
->filename
,len
)
1194 || !strcmp(psymtab
->filename
, basename(psymtab
->filename
)))
1196 files
[numfiles
++] = basename(psymtab
->filename
);
1201 ALL_SYMTABS (objfile
, symtab
)
1203 if (numfiles
== files_size
)
1205 files_size
= files_size
* 2;
1206 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1208 if (symtab
->filename
&& symtab
->linetable
&& symtab
->linetable
->nitems
)
1210 if (!len
|| !strncmp(pathname
, symtab
->filename
,len
)
1211 || !strcmp(symtab
->filename
, basename(symtab
->filename
)))
1213 files
[numfiles
++] = basename(symtab
->filename
);
1218 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1222 /* Discard the old result pointer, in case it has accumulated anything
1223 and set it to a new list object */
1225 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1227 for (i
= 0; i
< numfiles
; i
++)
1229 if (strcmp(files
[i
],lastfile
))
1230 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj(files
[i
], -1));
1231 lastfile
= files
[i
];
1239 comp_files (file1
, file2
)
1240 const void *file1
, *file2
;
1242 return strcmp(* (char **) file1
, * (char **) file2
);
1246 /* This implements the tcl command "gdb_search"
1250 * option - One of "functions", "variables" or "types"
1251 * regexp - The regular expression to look for.
1260 gdb_search (clientData
, interp
, objc
, objv
)
1261 ClientData clientData
;
1264 Tcl_Obj
*CONST objv
[];
1266 struct symbol_search
*ss
;
1267 struct symbol_search
*p
;
1268 struct cleanup
*old_chain
;
1269 Tcl_Obj
*list
, *result
, *CONST
*switch_objv
;
1270 int index
, switch_objc
, i
;
1271 namespace_enum space
;
1273 int static_only
, nfiles
;
1274 Tcl_Obj
**file_list
;
1276 static char *search_options
[] = { "functions", "variables", "types", (char *) NULL
};
1277 static char *switches
[] = { "-files", "-static" };
1278 enum search_opts
{ SEARCH_FUNCTIONS
, SEARCH_VARIABLES
, SEARCH_TYPES
};
1279 enum switches_opts
{ SWITCH_FILES
, SWITCH_STATIC_ONLY
};
1283 Tcl_WrongNumArgs (interp
, 1, objv
, "option regexp ?arg ...?");
1287 if (Tcl_GetIndexFromObj (interp
, objv
[1], search_options
, "option", 0,
1291 /* Unfortunately, we cannot teach search_symbols to search on
1292 multiple regexps, so we have to do a two-tier search for
1293 any searches which choose to narrow the playing field. */
1294 switch ((enum search_opts
) index
)
1296 case SEARCH_FUNCTIONS
:
1297 space
= FUNCTIONS_NAMESPACE
; break;
1298 case SEARCH_VARIABLES
:
1299 space
= VARIABLES_NAMESPACE
; break;
1301 space
= TYPES_NAMESPACE
; break;
1304 regexp
= Tcl_GetStringFromObj (objv
[2], NULL
);
1305 /* Process any switches that refine the search */
1306 switch_objc
= objc
- 3;
1307 switch_objv
= objv
+ 3;
1311 files
= (char **) NULL
;
1312 while (switch_objc
> 0)
1314 if (Tcl_GetIndexFromObj (interp
, switch_objv
[0], switches
,
1315 "option", 0, &index
) != TCL_OK
)
1317 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1321 switch ((enum switches_opts
) index
)
1324 if (switch_objc
< 2)
1326 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList -static 1|0]");
1327 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1330 Tcl_ListObjGetElements (interp
, switch_objv
[1], &nfiles
, &file_list
);
1331 files
= (char **) xmalloc (nfiles
);
1332 old_chain
= make_cleanup (free
, files
);
1334 for (i
= 0; i
< nfiles
; i
++)
1335 files
[i
] = Tcl_GetStringFromObj (file_list
[i
], NULL
);
1339 case SWITCH_STATIC_ONLY
:
1340 if (switch_objc
< 2)
1342 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList] [-static 1|0]");
1343 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1346 if ( Tcl_GetBooleanFromObj (interp
, switch_objv
[1], &static_only
) !=
1348 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1359 search_symbols (regexp
, space
, nfiles
, files
, &ss
);
1360 if (files
!= NULL
&& ss
!= NULL
)
1361 do_cleanups (old_chain
);
1362 old_chain
= make_cleanup (free_search_symbols
, ss
);
1364 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1366 for (p
= ss
; p
!= NULL
; p
= p
->next
)
1370 if (static_only
&& p
->block
!= STATIC_BLOCK
)
1373 elem
= Tcl_NewListObj (0, NULL
);
1375 if (p
->msymbol
== NULL
)
1376 Tcl_ListObjAppendElement (interp
, elem
,
1377 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->symbol
), -1));
1379 Tcl_ListObjAppendElement (interp
, elem
,
1380 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->msymbol
), -1));
1382 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, elem
);
1385 do_cleanups (old_chain
);
1389 /* This implements the tcl command gdb_listfuncs
1391 * It lists all the functions defined in a given file
1394 * file - the file to look in
1396 * A list of two element lists, the first element is
1397 * the symbol name, and the second is a boolean indicating
1398 * whether the symbol is demangled (1 for yes).
1402 gdb_listfuncs (clientData
, interp
, objc
, objv
)
1403 ClientData clientData
;
1406 Tcl_Obj
*CONST objv
[];
1408 struct symtab
*symtab
;
1409 struct blockvector
*bv
;
1414 Tcl_Obj
*funcVals
[2];
1418 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1421 symtab
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1424 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No such file", -1);
1428 if (mangled
== NULL
)
1430 mangled
= Tcl_NewBooleanObj(1);
1431 not_mangled
= Tcl_NewBooleanObj(0);
1432 Tcl_IncrRefCount(mangled
);
1433 Tcl_IncrRefCount(not_mangled
);
1436 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1438 bv
= BLOCKVECTOR (symtab
);
1439 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1441 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1442 /* Skip the sort if this block is always sorted. */
1443 if (!BLOCK_SHOULD_SORT (b
))
1444 sort_block_syms (b
);
1445 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1447 sym
= BLOCK_SYM (b
, j
);
1448 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1451 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1454 funcVals
[0] = Tcl_NewStringObj(name
, -1);
1455 funcVals
[1] = mangled
;
1459 funcVals
[0] = Tcl_NewStringObj(SYMBOL_NAME(sym
), -1);
1460 funcVals
[1] = not_mangled
;
1462 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1463 Tcl_NewListObj (2, funcVals
));
1472 * This section contains all the commands that act on the registers:
1475 /* This is a sort of mapcar function for operations on registers */
1478 map_arg_registers (objc
, objv
, func
, argp
)
1480 Tcl_Obj
*CONST objv
[];
1481 void (*func
) PARAMS ((int regnum
, void *argp
));
1486 /* Note that the test for a valid register must include checking the
1487 reg_names array because NUM_REGS may be allocated for the union of the
1488 register sets within a family of related processors. In this case, the
1489 trailing entries of reg_names will change depending upon the particular
1490 processor being debugged. */
1492 if (objc
== 0) /* No args, just do all the regs */
1496 && reg_names
[regnum
] != NULL
1497 && *reg_names
[regnum
] != '\000';
1499 func (regnum
, argp
);
1504 /* Else, list of register #s, just do listed regs */
1505 for (; objc
> 0; objc
--, objv
++)
1508 if (Tcl_GetIntFromObj (NULL
, *objv
, ®num
) != TCL_OK
) {
1509 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1514 && regnum
< NUM_REGS
1515 && reg_names
[regnum
] != NULL
1516 && *reg_names
[regnum
] != '\000')
1517 func (regnum
, argp
);
1520 Tcl_SetStringObj (result_ptr
->obj_ptr
, "bad register number", -1);
1528 /* This implements the TCL command `gdb_regnames', which returns a list of
1529 all of the register names. */
1532 gdb_regnames (clientData
, interp
, objc
, objv
)
1533 ClientData clientData
;
1536 Tcl_Obj
*CONST objv
[];
1541 return map_arg_registers (objc
, objv
, get_register_name
, NULL
);
1545 get_register_name (regnum
, argp
)
1547 void *argp
; /* Ignored */
1549 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1550 Tcl_NewStringObj (reg_names
[regnum
], -1));
1553 /* This implements the tcl command gdb_fetch_registers
1554 * Pass it a list of register names, and it will
1555 * return their values as a list.
1558 * format: The format string for printing the values
1559 * args: the registers to look for
1561 * A list of their values.
1565 gdb_fetch_registers (clientData
, interp
, objc
, objv
)
1566 ClientData clientData
;
1569 Tcl_Obj
*CONST objv
[];
1575 Tcl_SetStringObj (result_ptr
->obj_ptr
,
1576 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
1580 format
= *(Tcl_GetStringFromObj(objv
[0], NULL
));
1584 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Output the results as a list */
1585 result
= map_arg_registers (objc
, objv
, get_register
, (void *) format
);
1586 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
1592 get_register (regnum
, fp
)
1596 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1597 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
1598 int format
= (int)fp
;
1603 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1605 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1606 Tcl_NewStringObj ("Optimized out", -1));
1610 /* Convert raw data to virtual format if necessary. */
1612 if (REGISTER_CONVERTIBLE (regnum
))
1614 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
1615 raw_buffer
, virtual_buffer
);
1618 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1623 printf_filtered ("0x");
1624 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1626 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1627 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1628 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
1632 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
1633 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1637 /* This implements the tcl command get_pc_reg
1638 * It returns the value of the PC register
1643 * The value of the pc register.
1647 get_pc_register (clientData
, interp
, objc
, objv
)
1648 ClientData clientData
;
1651 Tcl_Obj
*CONST objv
[];
1655 sprintf (buff
, "0x%llx",(long long) read_register (PC_REGNUM
));
1656 Tcl_SetStringObj(result_ptr
->obj_ptr
, buff
, -1);
1660 /* This implements the tcl command "gdb_changed_register_list"
1661 * It takes a list of registers, and returns a list of
1662 * the registers on that list that have changed since the last
1663 * time the proc was called.
1666 * A list of registers.
1668 * A list of changed registers.
1672 gdb_changed_register_list (clientData
, interp
, objc
, objv
)
1673 ClientData clientData
;
1676 Tcl_Obj
*CONST objv
[];
1681 return map_arg_registers (objc
, objv
, register_changed_p
, NULL
);
1685 register_changed_p (regnum
, argp
)
1687 void *argp
; /* Ignored */
1689 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1691 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1694 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1695 REGISTER_RAW_SIZE (regnum
)) == 0)
1698 /* Found a changed register. Save new value and return its number. */
1700 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1701 REGISTER_RAW_SIZE (regnum
));
1703 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(regnum
));
1707 * This section contains the commands that deal with tracepoints:
1710 /* return a list of all tracepoint numbers in interpreter */
1712 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
1713 ClientData clientData
;
1716 Tcl_Obj
*CONST objv
[];
1718 struct tracepoint
*tp
;
1720 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1722 ALL_TRACEPOINTS (tp
)
1723 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->number
));
1728 /* returns -1 if not found, tracepoint # if found */
1730 tracepoint_exists (char * args
)
1732 struct tracepoint
*tp
;
1734 struct symtabs_and_lines sals
;
1738 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1739 if (sals
.nelts
== 1)
1741 resolve_sal_pc (&sals
.sals
[0]);
1742 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
1743 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
1746 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
1747 strcat (file
, sals
.sals
[0].symtab
->filename
);
1749 ALL_TRACEPOINTS (tp
)
1751 if (tp
->address
== sals
.sals
[0].pc
)
1752 result
= tp
->number
;
1754 /* Why is this here? This messes up assembly traces */
1755 else if (tp
->source_file
!= NULL
1756 && strcmp (tp
->source_file
, file
) == 0
1757 && sals
.sals
[0].line
== tp
->line_number
)
1758 result
= tp
->number
;
1769 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
1770 ClientData clientData
;
1773 Tcl_Obj
*CONST objv
[];
1779 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1780 Tcl_GetStringFromObj (objv
[0], NULL
),
1781 " function:line|function|line|*addr\"", NULL
);
1785 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1787 Tcl_SetIntObj (result_ptr
->obj_ptr
, tracepoint_exists (args
));
1792 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
1793 ClientData clientData
;
1796 Tcl_Obj
*CONST objv
[];
1798 struct symtab_and_line sal
;
1800 struct tracepoint
*tp
;
1801 struct action_line
*al
;
1802 Tcl_Obj
*action_list
;
1803 char *filename
, *funcname
;
1808 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1812 if (Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
) != TCL_OK
)
1814 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1818 ALL_TRACEPOINTS (tp
)
1819 if (tp
->number
== tpnum
)
1824 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Tracepoint #%d does not exist", -1);
1828 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1829 sal
= find_pc_line (tp
->address
, 0);
1830 filename
= symtab_to_filename (sal
.symtab
);
1831 if (filename
== NULL
)
1833 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1834 Tcl_NewStringObj (filename
, -1));
1835 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
1836 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (funcname
, -1));
1837 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (sal
.line
));
1838 sprintf (tmp
, "0x%lx", tp
->address
);
1839 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (tmp
, -1));
1840 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->enabled
));
1841 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->pass_count
));
1842 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->step_count
));
1843 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->thread
));
1844 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->hit_count
));
1846 /* Append a list of actions */
1847 action_list
= Tcl_NewObj ();
1848 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
1850 Tcl_ListObjAppendElement (interp
, action_list
,
1851 Tcl_NewStringObj (al
->action
, -1));
1853 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, action_list
);
1860 gdb_trace_status (clientData
, interp
, objc
, objv
)
1861 ClientData clientData
;
1864 Tcl_Obj
*CONST objv
[];
1868 if (trace_running_p
)
1871 Tcl_SetIntObj (result_ptr
->obj_ptr
, result
);
1878 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
1879 ClientData clientData
;
1882 Tcl_Obj
*CONST objv
[];
1886 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1887 Tcl_GetStringFromObj (objv
[0], NULL
),
1888 " linespec\"", NULL
);
1892 Tcl_SetIntObj (result_ptr
->obj_ptr
, get_traceframe_number ());
1897 /* This implements the tcl command gdb_actions
1898 * It sets actions for a given tracepoint.
1901 * number: the tracepoint in question
1902 * actions: the actions to add to this tracepoint
1908 gdb_actions_command (clientData
, interp
, objc
, objv
)
1909 ClientData clientData
;
1912 Tcl_Obj
*CONST objv
[];
1914 struct tracepoint
*tp
;
1916 int nactions
, i
, len
;
1917 char *number
, *args
, *action
;
1919 struct action_line
*next
= NULL
, *temp
;
1920 enum actionline_type linetype
;
1924 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # args: should be: \"",
1925 Tcl_GetStringFromObj (objv
[0], NULL
),
1926 " number actions\"", NULL
);
1930 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
1931 tp
= get_tracepoint_by_number (&args
);
1934 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "Tracepoint \"", number
, "\" does not exist", NULL
);
1938 /* Free any existing actions */
1939 if (tp
->actions
!= NULL
)
1944 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
1946 /* Add the actions to the tracepoint */
1947 for (i
= 0; i
< nactions
; i
++)
1949 temp
= xmalloc (sizeof (struct action_line
));
1951 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
1952 temp
->action
= savestring (action
, len
);
1954 linetype
= validate_actionline (&(temp
->action
), tp
);
1956 if (linetype
== BADLINE
)
1978 * This section has commands that handle source disassembly.
1981 /* This implements the tcl command gdb_disassemble
1984 * source_with_assm - must be "source" or "nosource"
1985 * low_address - the address from which to start disassembly
1986 * ?hi_address? - the address to which to disassemble, defaults
1987 * to the end of the function containing low_address.
1989 * The disassembled code is passed to fputs_unfiltered, so it
1990 * either goes to the console if result_ptr->obj_ptr is NULL or to
1995 gdb_disassemble (clientData
, interp
, objc
, objv
)
1996 ClientData clientData
;
1999 Tcl_Obj
*CONST objv
[];
2001 CORE_ADDR pc
, low
, high
;
2002 int mixed_source_and_assembly
;
2003 static disassemble_info di
;
2004 static int di_initialized
;
2007 if (objc
!= 3 && objc
!= 4)
2008 error ("wrong # args");
2010 if (! di_initialized
)
2012 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
2013 (fprintf_ftype
) fprintf_unfiltered
);
2014 di
.flavour
= bfd_target_unknown_flavour
;
2015 di
.memory_error_func
= dis_asm_memory_error
;
2016 di
.print_address_func
= dis_asm_print_address
;
2020 di
.mach
= tm_print_insn_info
.mach
;
2021 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
2022 di
.endian
= BFD_ENDIAN_BIG
;
2024 di
.endian
= BFD_ENDIAN_LITTLE
;
2026 arg_ptr
= Tcl_GetStringFromObj (objv
[1], NULL
);
2027 if (*arg_ptr
== 's' && strcmp (arg_ptr
, "source") == 0)
2028 mixed_source_and_assembly
= 1;
2029 else if (*arg_ptr
== 'n' && strcmp (arg_ptr
, "nosource") == 0)
2030 mixed_source_and_assembly
= 0;
2032 error ("First arg must be 'source' or 'nosource'");
2034 low
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[2], NULL
));
2038 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
2039 error ("No function contains specified address");
2042 high
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[3], NULL
));
2044 /* If disassemble_from_exec == -1, then we use the following heuristic to
2045 determine whether or not to do disassembly from target memory or from the
2048 If we're debugging a local process, read target memory, instead of the
2049 exec file. This makes disassembly of functions in shared libs work
2052 Else, we're debugging a remote process, and should disassemble from the
2053 exec file for speed. However, this is no good if the target modifies its
2054 code (for relocation, or whatever).
2057 if (disassemble_from_exec
== -1)
2058 if (strcmp (target_shortname
, "child") == 0
2059 || strcmp (target_shortname
, "procfs") == 0
2060 || strcmp (target_shortname
, "vxprocess") == 0)
2061 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
2063 disassemble_from_exec
= 1; /* It's remote, read the exec file */
2065 if (disassemble_from_exec
)
2066 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
2068 di
.read_memory_func
= dis_asm_read_memory
;
2070 /* If just doing straight assembly, all we need to do is disassemble
2071 everything between low and high. If doing mixed source/assembly, we've
2072 got a totally different path to follow. */
2074 if (mixed_source_and_assembly
)
2075 { /* Come here for mixed source/assembly */
2076 /* The idea here is to present a source-O-centric view of a function to
2077 the user. This means that things are presented in source order, with
2078 (possibly) out of order assembly immediately following. */
2079 struct symtab
*symtab
;
2080 struct linetable_entry
*le
;
2083 struct my_line_entry
*mle
;
2084 struct symtab_and_line sal
;
2089 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
2094 /* First, convert the linetable to a bunch of my_line_entry's. */
2096 le
= symtab
->linetable
->item
;
2097 nlines
= symtab
->linetable
->nitems
;
2102 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
2106 /* Copy linetable entries for this function into our data structure, creating
2107 end_pc's and setting out_of_order as appropriate. */
2109 /* First, skip all the preceding functions. */
2111 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
2113 /* Now, copy all entries before the end of this function. */
2116 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
2118 if (le
[i
].line
== le
[i
+ 1].line
2119 && le
[i
].pc
== le
[i
+ 1].pc
)
2120 continue; /* Ignore duplicates */
2122 mle
[newlines
].line
= le
[i
].line
;
2123 if (le
[i
].line
> le
[i
+ 1].line
)
2125 mle
[newlines
].start_pc
= le
[i
].pc
;
2126 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
2130 /* If we're on the last line, and it's part of the function, then we need to
2131 get the end pc in a special way. */
2136 mle
[newlines
].line
= le
[i
].line
;
2137 mle
[newlines
].start_pc
= le
[i
].pc
;
2138 sal
= find_pc_line (le
[i
].pc
, 0);
2139 mle
[newlines
].end_pc
= sal
.end
;
2143 /* Now, sort mle by line #s (and, then by addresses within lines). */
2146 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
2148 /* Now, for each line entry, emit the specified lines (unless they have been
2149 emitted before), followed by the assembly code for that line. */
2151 next_line
= 0; /* Force out first line */
2152 for (i
= 0; i
< newlines
; i
++)
2154 /* Print out everything from next_line to the current line. */
2156 if (mle
[i
].line
>= next_line
)
2159 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
2161 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
2163 next_line
= mle
[i
].line
+ 1;
2166 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
2169 fputs_unfiltered (" ", gdb_stdout
);
2170 print_address (pc
, gdb_stdout
);
2171 fputs_unfiltered (":\t ", gdb_stdout
);
2172 pc
+= (*tm_print_insn
) (pc
, &di
);
2173 fputs_unfiltered ("\n", gdb_stdout
);
2180 for (pc
= low
; pc
< high
; )
2183 fputs_unfiltered (" ", gdb_stdout
);
2184 print_address (pc
, gdb_stdout
);
2185 fputs_unfiltered (":\t ", gdb_stdout
);
2186 pc
+= (*tm_print_insn
) (pc
, &di
);
2187 fputs_unfiltered ("\n", gdb_stdout
);
2191 gdb_flush (gdb_stdout
);
2196 /* This is the memory_read_func for gdb_disassemble when we are
2197 disassembling from the exec file. */
2200 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
2204 disassemble_info
*info
;
2206 extern struct target_ops exec_ops
;
2210 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
2221 /* This will be passed to qsort to sort the results of the disassembly */
2224 compare_lines (mle1p
, mle2p
)
2228 struct my_line_entry
*mle1
, *mle2
;
2231 mle1
= (struct my_line_entry
*) mle1p
;
2232 mle2
= (struct my_line_entry
*) mle2p
;
2234 val
= mle1
->line
- mle2
->line
;
2239 return mle1
->start_pc
- mle2
->start_pc
;
2242 /* This implements the TCL command `gdb_loc',
2245 * ?symbol? The symbol or address to locate - defaults to pc
2247 * a list consisting of the following:
2248 * basename, function name, filename, line number, address, current pc
2252 gdb_loc (clientData
, interp
, objc
, objv
)
2253 ClientData clientData
;
2256 Tcl_Obj
*CONST objv
[];
2259 struct symtab_and_line sal
;
2260 char *funcname
, *fname
;
2263 if (!have_full_symbols () && !have_partial_symbols ())
2265 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No symbol table is loaded", -1);
2271 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
2273 /* Note - this next line is not correct on all architectures. */
2274 /* For a graphical debugger we really want to highlight the */
2275 /* assembly line that called the next function on the stack. */
2276 /* Many architectures have the next instruction saved as the */
2277 /* pc on the stack, so what happens is the next instruction is hughlighted. */
2279 pc
= selected_frame
->pc
;
2280 sal
= find_pc_line (selected_frame
->pc
,
2281 selected_frame
->next
!= NULL
2282 && !selected_frame
->next
->signal_handler_caller
2283 && !frame_in_dummy (selected_frame
->next
));
2288 sal
= find_pc_line (stop_pc
, 0);
2293 struct symtabs_and_lines sals
;
2296 sals
= decode_line_spec (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
2302 if (sals
.nelts
!= 1)
2304 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Ambiguous line spec", -1);
2312 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
2317 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2318 Tcl_NewStringObj (sal
.symtab
->filename
, -1));
2320 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewStringObj ("", 0));
2322 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
2323 fname
= cplus_demangle (funcname
, 0);
2326 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2327 Tcl_NewStringObj (fname
, -1));
2331 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2332 Tcl_NewStringObj (funcname
, -1));
2334 filename
= symtab_to_filename (sal
.symtab
);
2335 if (filename
== NULL
)
2338 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2339 Tcl_NewStringObj (filename
, -1));
2340 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(sal
.line
)); /* line number */
2341 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
2342 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
2346 /* This implements the Tcl command 'gdb_get_mem', which
2347 * dumps a block of memory
2349 * gdb_get_mem addr form size num aschar
2351 * addr: address of data to dump
2352 * form: a char indicating format
2353 * size: size of each element; 1,2,4, or 8 bytes
2354 * num: the number of bytes to read
2355 * acshar: an optional ascii character to use in ASCII dump
2358 * a list of elements followed by an optional ASCII dump
2362 gdb_get_mem (clientData
, interp
, objc
, objv
)
2363 ClientData clientData
;
2366 Tcl_Obj
*CONST objv
[];
2368 int size
, asize
, i
, j
, bc
;
2370 int nbytes
, rnum
, bpr
;
2372 char format
, c
, *ptr
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
2373 struct type
*val_type
;
2375 if (objc
< 6 || objc
> 7)
2377 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2378 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2382 if (Tcl_GetIntFromObj (interp
, objv
[3], &size
) != TCL_OK
)
2384 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2389 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid size, must be > 0", -1);
2393 if (Tcl_GetIntFromObj (interp
, objv
[4], &nbytes
) != TCL_OK
)
2395 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2400 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid number of bytes, must be > 0",
2405 if (Tcl_GetIntFromObj (interp
, objv
[5], &bpr
) != TCL_OK
)
2407 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2412 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid bytes per row, must be > 0", -1);
2416 if (Tcl_GetLongFromObj (interp
, objv
[1], &tmp
) != TCL_OK
)
2419 addr
= (CORE_ADDR
) tmp
;
2421 format
= *(Tcl_GetStringFromObj (objv
[2], NULL
));
2422 mbuf
= (char *)malloc (nbytes
+32);
2425 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Out of memory.", -1);
2429 memset (mbuf
, 0, nbytes
+32);
2432 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
2435 aschar
= *(Tcl_GetStringFromObj(objv
[6], NULL
));
2441 val_type
= builtin_type_char
;
2445 val_type
= builtin_type_short
;
2449 val_type
= builtin_type_int
;
2453 val_type
= builtin_type_long_long
;
2457 val_type
= builtin_type_char
;
2461 bc
= 0; /* count of bytes in a row */
2462 buff
[0] = '"'; /* buffer for ascii dump */
2463 bptr
= &buff
[1]; /* pointer for ascii dump */
2465 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Build up the result as a list... */
2467 for (i
=0; i
< nbytes
; i
+= size
)
2471 fputs_unfiltered ("N/A ", gdb_stdout
);
2473 for ( j
= 0; j
< size
; j
++)
2478 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
2482 for ( j
= 0; j
< size
; j
++)
2485 if (c
< 32 || c
> 126)
2497 if (aschar
&& (bc
>= bpr
))
2499 /* end of row. print it and reset variables */
2504 fputs_unfiltered (buff
, gdb_stdout
);
2509 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
2517 /* This implements the tcl command "gdb_loadfile"
2518 * It loads a c source file into a text widget.
2521 * widget: the name of the text widget to fill
2522 * filename: the name of the file to load
2523 * linenumbers: A boolean indicating whether or not to display line numbers.
2528 /* In this routine, we will build up a "line table", i.e. a
2529 * table of bits showing which lines in the source file are executible.
2530 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2532 * Its size limits the maximum number of lines
2533 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2534 * the file is loaded, so it is OK to make this very large.
2535 * Additional memory will be allocated if needed. */
2536 #define LTABLE_SIZE 20000
2538 gdb_loadfile (clientData
, interp
, objc
, objv
)
2539 ClientData clientData
;
2542 Tcl_Obj
*CONST objv
[];
2544 char *file
, *widget
, *buf
, msg
[128];
2545 int linenumbers
, ln
, anum
, lnum
, ltable_size
;
2548 struct symtab
*symtab
;
2549 struct linetable_entry
*le
;
2552 Tcl_DString text_cmd_1
, text_cmd_2
, *cur_cmd
;
2553 char line
[1024], line_num_buf
[16];
2554 int prefix_len_1
, prefix_len_2
, cur_prefix_len
, widget_len
;
2559 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
2563 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
2564 if ( Tk_NameToWindow (interp
, widget
, Tk_MainWindow (interp
)) == NULL
)
2569 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
2570 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
2572 if ((fp
= fopen ( file
, "r" )) == NULL
)
2574 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Can't open file for reading", -1);
2578 symtab
= full_lookup_symtab (file
);
2581 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "File not found in symtab", -1);
2586 if (stat (file
, &st
) < 0)
2588 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
2593 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
2594 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
2596 mtime
= bfd_get_mtime(exec_bfd
);
2598 if (mtime
&& mtime
< st
.st_mtime
)
2599 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2602 /* Source linenumbers don't appear to be in order, and a sort is */
2603 /* too slow so the fastest solution is just to allocate a huge */
2604 /* array and set the array entry for each linenumber */
2606 ltable_size
= LTABLE_SIZE
;
2607 ltable
= (char *)malloc (LTABLE_SIZE
);
2610 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2615 memset (ltable
, 0, LTABLE_SIZE
);
2617 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
2619 le
= symtab
->linetable
->item
;
2620 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
2622 lnum
= le
->line
>> 3;
2623 if (lnum
>= ltable_size
)
2626 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
2627 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
2629 if (new_ltable
== NULL
)
2631 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2636 ltable
= new_ltable
;
2638 ltable
[lnum
] |= 1 << (le
->line
% 8);
2642 Tcl_DStringInit(&text_cmd_1
);
2643 Tcl_DStringInit(&text_cmd_2
);
2647 widget_len
= strlen (widget
);
2650 Tcl_DStringAppend (&text_cmd_1
, widget
, widget_len
);
2651 Tcl_DStringAppend (&text_cmd_2
, widget
, widget_len
);
2655 Tcl_DStringAppend (&text_cmd_1
, " insert end {-\t", -1);
2656 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2658 Tcl_DStringAppend (&text_cmd_2
, " insert end { \t", -1);
2659 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2661 while (fgets (line
+ 1, 980, fp
))
2663 sprintf (line_num_buf
, "%d", ln
);
2664 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2666 cur_cmd
= &text_cmd_1
;
2667 cur_prefix_len
= prefix_len_1
;
2668 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2669 Tcl_DStringAppend (cur_cmd
, "} break_tag", 11);
2673 cur_cmd
= &text_cmd_2
;
2674 cur_prefix_len
= prefix_len_2
;
2675 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2676 Tcl_DStringAppend (cur_cmd
, "} \"\"", 4);
2679 Tcl_DStringAppendElement (cur_cmd
, line
);
2680 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2682 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2683 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2689 Tcl_DStringAppend (&text_cmd_1
, " insert end {- } break_tag", -1);
2690 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2691 Tcl_DStringAppend (&text_cmd_2
, " insert end { } \"\"", -1);
2692 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2695 while (fgets (line
+ 1, 980, fp
))
2697 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2699 cur_cmd
= &text_cmd_1
;
2700 cur_prefix_len
= prefix_len_1
;
2704 cur_cmd
= &text_cmd_2
;
2705 cur_prefix_len
= prefix_len_2
;
2708 Tcl_DStringAppendElement (cur_cmd
, line
);
2709 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2711 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2712 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2718 Tcl_DStringFree (&text_cmd_1
);
2719 Tcl_DStringFree (&text_cmd_2
);
2726 * This section contains commands for manipulation of breakpoints.
2730 /* set a breakpoint by source file and line number */
2731 /* flags are as follows: */
2732 /* least significant 2 bits are disposition, rest is */
2733 /* type (normally 0).
2736 bp_breakpoint, Normal breakpoint
2737 bp_hardware_breakpoint, Hardware assisted breakpoint
2740 Disposition of breakpoint. Ie: what to do after hitting it.
2743 del_at_next_stop, Delete at next stop, whether hit or not
2745 donttouch Leave it alone
2749 /* This implements the tcl command "gdb_set_bp"
2750 * It sets breakpoints, and runs the Tcl command
2751 * gdbtk_tcl_breakpoint create
2752 * to register the new breakpoint with the GUI.
2755 * filename: the file in which to set the breakpoint
2756 * line: the line number for the breakpoint
2757 * type: the type of the breakpoint
2759 * The return value of the call to gdbtk_tcl_breakpoint.
2763 gdb_set_bp (clientData
, interp
, objc
, objv
)
2764 ClientData clientData
;
2767 Tcl_Obj
*CONST objv
[];
2770 struct symtab_and_line sal
;
2771 int line
, flags
, ret
;
2772 struct breakpoint
*b
;
2778 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
2782 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
2783 if (sal
.symtab
== NULL
)
2786 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
2788 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2792 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
2794 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2799 if (!find_line_pc (sal
.symtab
, sal
.line
, &sal
.pc
))
2802 sal
.section
= find_pc_overlay (sal
.pc
);
2803 b
= set_raw_breakpoint (sal
);
2804 set_breakpoint_count (breakpoint_count
+ 1);
2805 b
->number
= breakpoint_count
;
2806 b
->type
= flags
>> 2;
2807 b
->disposition
= flags
& 3;
2809 /* FIXME: this won't work for duplicate basenames! */
2810 sprintf (buf
, "%s:%d", basename (Tcl_GetStringFromObj ( objv
[1], NULL
)), line
);
2811 b
->addr_string
= strsave (buf
);
2813 /* now send notification command back to GUI */
2815 Tcl_DStringInit (&cmd
);
2817 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2818 sprintf (buf
, "%d", b
->number
);
2819 Tcl_DStringAppendElement(&cmd
, buf
);
2820 sprintf (buf
, "0x%x", sal
.pc
);
2821 Tcl_DStringAppendElement (&cmd
, buf
);
2822 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[2], NULL
));
2823 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[1], NULL
));
2825 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2826 Tcl_DStringFree (&cmd
);
2830 /* This implements the tcl command gdb_get_breakpoint_info
2836 * A list with {file, function, line_number, address, type, enabled?,
2837 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
2841 gdb_get_breakpoint_info (clientData
, interp
, objc
, objv
)
2842 ClientData clientData
;
2845 Tcl_Obj
*CONST objv
[];
2847 struct symtab_and_line sal
;
2848 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
2849 "finish", "watchpoint", "hardware watchpoint",
2850 "read watchpoint", "access watchpoint",
2851 "longjmp", "longjmp resume", "step resume",
2852 "through sigtramp", "watchpoint scope",
2854 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
2855 struct command_line
*cmd
;
2857 struct breakpoint
*b
;
2858 extern struct breakpoint
*breakpoint_chain
;
2859 char *funcname
, *fname
, *filename
;
2864 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong number of args, should be \"breakpoint\"", -1);
2868 if ( Tcl_GetIntFromObj(NULL
, objv
[1], &bpnum
) != TCL_OK
)
2870 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2874 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2875 if (b
->number
== bpnum
)
2878 if (!b
|| b
->type
!= bp_breakpoint
)
2880 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Breakpoint #%d does not exist", -1);
2884 sal
= find_pc_line (b
->address
, 0);
2886 filename
= symtab_to_filename (sal
.symtab
);
2887 if (filename
== NULL
)
2890 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
2891 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2892 Tcl_NewStringObj (filename
, -1));
2894 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
2895 fname
= cplus_demangle (funcname
, 0);
2898 new_obj
= Tcl_NewStringObj (fname
, -1);
2902 new_obj
= Tcl_NewStringObj (funcname
, -1);
2904 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2906 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->line_number
));
2907 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%lx", b
->address
);
2908 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2909 Tcl_NewStringObj (bptypes
[b
->type
], -1));
2910 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewBooleanObj(b
->enable
== enabled
));
2911 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2912 Tcl_NewStringObj (bpdisp
[b
->disposition
], -1));
2913 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->ignore_count
));
2915 new_obj
= Tcl_NewObj();
2916 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
2917 Tcl_ListObjAppendElement (NULL
, new_obj
,
2918 Tcl_NewStringObj (cmd
->line
, -1));
2919 Tcl_ListObjAppendElement(NULL
, result_ptr
->obj_ptr
, new_obj
);
2921 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2922 Tcl_NewStringObj (b
->cond_string
, -1));
2924 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->thread
));
2925 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->hit_count
));
2931 /* This implements the tcl command gdb_get_breakpoint_list
2932 * It builds up a list of the current breakpoints.
2937 * A list of breakpoint numbers.
2941 gdb_get_breakpoint_list (clientData
, interp
, objc
, objv
)
2942 ClientData clientData
;
2945 Tcl_Obj
*CONST objv
[];
2947 struct breakpoint
*b
;
2948 extern struct breakpoint
*breakpoint_chain
;
2952 error ("wrong number of args, none are allowed");
2954 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2955 if (b
->type
== bp_breakpoint
)
2957 new_obj
= Tcl_NewIntObj (b
->number
);
2958 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2966 * This section contains a bunch of miscellaneous utility commands
2969 /* This implements the tcl command gdb_path_conv
2971 * On Windows, it canonicalizes the pathname,
2972 * On Unix, it is a no op.
2977 * The canonicalized path.
2981 gdb_path_conv (clientData
, interp
, objc
, objv
)
2982 ClientData clientData
;
2985 Tcl_Obj
*CONST objv
[];
2988 error ("wrong # args");
2992 char pathname
[256], *ptr
;
2994 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj(objv
[1], NULL
), pathname
);
2995 for (ptr
= pathname
; *ptr
; ptr
++)
3000 Tcl_SetStringObj (result_ptr
->obj_ptr
, pathname
, -1);
3003 Tcl_SetStringObj (result_ptr
->obj_ptr
, Tcl_GetStringFromObj (objv
[1], NULL
), -1);
3010 * This section has utility routines that are not Tcl commands.
3014 perror_with_name_wrapper (args
)
3017 perror_with_name (args
);
3021 /* The lookup_symtab() in symtab.c doesn't work correctly */
3022 /* It will not work will full pathnames and if multiple */
3023 /* source files have the same basename, it will return */
3024 /* the first one instead of the correct one. This version */
3025 /* also always makes sure symtab->fullname is set. */
3027 static struct symtab
*
3028 full_lookup_symtab(file
)
3032 struct objfile
*objfile
;
3033 char *bfile
, *fullname
;
3034 struct partial_symtab
*pt
;
3039 /* first try a direct lookup */
3040 st
= lookup_symtab (file
);
3044 symtab_to_filename(st
);
3048 /* if the direct approach failed, try */
3049 /* looking up the basename and checking */
3050 /* all matches with the fullname */
3051 bfile
= basename (file
);
3052 ALL_SYMTABS (objfile
, st
)
3054 if (!strcmp (bfile
, basename(st
->filename
)))
3057 fullname
= symtab_to_filename (st
);
3059 fullname
= st
->fullname
;
3061 if (!strcmp (file
, fullname
))
3066 /* still no luck? look at psymtabs */
3067 ALL_PSYMTABS (objfile
, pt
)
3069 if (!strcmp (bfile
, basename(pt
->filename
)))
3071 st
= PSYMTAB_TO_SYMTAB (pt
);
3074 fullname
= symtab_to_filename (st
);
3075 if (!strcmp (file
, fullname
))