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
= NULL
;
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", (char *) NULL
};
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 ...?");
1284 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1288 if (Tcl_GetIndexFromObj (interp
, objv
[1], search_options
, "option", 0,
1291 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1295 /* Unfortunately, we cannot teach search_symbols to search on
1296 multiple regexps, so we have to do a two-tier search for
1297 any searches which choose to narrow the playing field. */
1298 switch ((enum search_opts
) index
)
1300 case SEARCH_FUNCTIONS
:
1301 space
= FUNCTIONS_NAMESPACE
; break;
1302 case SEARCH_VARIABLES
:
1303 space
= VARIABLES_NAMESPACE
; break;
1305 space
= TYPES_NAMESPACE
; break;
1308 regexp
= Tcl_GetStringFromObj (objv
[2], NULL
);
1309 /* Process any switches that refine the search */
1310 switch_objc
= objc
- 3;
1311 switch_objv
= objv
+ 3;
1315 files
= (char **) NULL
;
1316 while (switch_objc
> 0)
1318 if (Tcl_GetIndexFromObj (interp
, switch_objv
[0], switches
,
1319 "option", 0, &index
) != TCL_OK
)
1321 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1325 switch ((enum switches_opts
) index
)
1330 if (switch_objc
< 2)
1332 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList -static 1|0]");
1333 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1336 result
= Tcl_ListObjGetElements (interp
, switch_objv
[1], &nfiles
, &file_list
);
1337 if (result
!= TCL_OK
)
1340 files
= (char **) xmalloc (nfiles
* sizeof (char *));
1341 for (i
= 0; i
< nfiles
; i
++)
1342 files
[i
] = Tcl_GetStringFromObj (file_list
[i
], NULL
);
1347 case SWITCH_STATIC_ONLY
:
1348 if (switch_objc
< 2)
1350 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList] [-static 1|0]");
1351 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1354 if ( Tcl_GetBooleanFromObj (interp
, switch_objv
[1], &static_only
) !=
1356 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1366 search_symbols (regexp
, space
, nfiles
, files
, &ss
);
1368 old_chain
= make_cleanup (free_search_symbols
, ss
);
1370 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1372 for (p
= ss
; p
!= NULL
; p
= p
->next
)
1376 if (static_only
&& p
->block
!= STATIC_BLOCK
)
1379 elem
= Tcl_NewListObj (0, NULL
);
1381 if (p
->msymbol
== NULL
)
1382 Tcl_ListObjAppendElement (interp
, elem
,
1383 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->symbol
), -1));
1385 Tcl_ListObjAppendElement (interp
, elem
,
1386 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->msymbol
), -1));
1388 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, elem
);
1392 do_cleanups (old_chain
);
1397 /* This implements the tcl command gdb_listfuncs
1399 * It lists all the functions defined in a given file
1402 * file - the file to look in
1404 * A list of two element lists, the first element is
1405 * the symbol name, and the second is a boolean indicating
1406 * whether the symbol is demangled (1 for yes).
1410 gdb_listfuncs (clientData
, interp
, objc
, objv
)
1411 ClientData clientData
;
1414 Tcl_Obj
*CONST objv
[];
1416 struct symtab
*symtab
;
1417 struct blockvector
*bv
;
1422 Tcl_Obj
*funcVals
[2];
1426 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1429 symtab
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1432 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No such file", -1);
1436 if (mangled
== NULL
)
1438 mangled
= Tcl_NewBooleanObj(1);
1439 not_mangled
= Tcl_NewBooleanObj(0);
1440 Tcl_IncrRefCount(mangled
);
1441 Tcl_IncrRefCount(not_mangled
);
1444 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1446 bv
= BLOCKVECTOR (symtab
);
1447 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1449 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1450 /* Skip the sort if this block is always sorted. */
1451 if (!BLOCK_SHOULD_SORT (b
))
1452 sort_block_syms (b
);
1453 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1455 sym
= BLOCK_SYM (b
, j
);
1456 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1459 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1462 funcVals
[0] = Tcl_NewStringObj(name
, -1);
1463 funcVals
[1] = mangled
;
1467 funcVals
[0] = Tcl_NewStringObj(SYMBOL_NAME(sym
), -1);
1468 funcVals
[1] = not_mangled
;
1470 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1471 Tcl_NewListObj (2, funcVals
));
1480 * This section contains all the commands that act on the registers:
1483 /* This is a sort of mapcar function for operations on registers */
1486 map_arg_registers (objc
, objv
, func
, argp
)
1488 Tcl_Obj
*CONST objv
[];
1489 void (*func
) PARAMS ((int regnum
, void *argp
));
1494 /* Note that the test for a valid register must include checking the
1495 reg_names array because NUM_REGS may be allocated for the union of the
1496 register sets within a family of related processors. In this case, the
1497 trailing entries of reg_names will change depending upon the particular
1498 processor being debugged. */
1500 if (objc
== 0) /* No args, just do all the regs */
1504 && reg_names
[regnum
] != NULL
1505 && *reg_names
[regnum
] != '\000';
1507 func (regnum
, argp
);
1512 /* Else, list of register #s, just do listed regs */
1513 for (; objc
> 0; objc
--, objv
++)
1516 if (Tcl_GetIntFromObj (NULL
, *objv
, ®num
) != TCL_OK
) {
1517 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1522 && regnum
< NUM_REGS
1523 && reg_names
[regnum
] != NULL
1524 && *reg_names
[regnum
] != '\000')
1525 func (regnum
, argp
);
1528 Tcl_SetStringObj (result_ptr
->obj_ptr
, "bad register number", -1);
1536 /* This implements the TCL command `gdb_regnames', which returns a list of
1537 all of the register names. */
1540 gdb_regnames (clientData
, interp
, objc
, objv
)
1541 ClientData clientData
;
1544 Tcl_Obj
*CONST objv
[];
1549 return map_arg_registers (objc
, objv
, get_register_name
, NULL
);
1553 get_register_name (regnum
, argp
)
1555 void *argp
; /* Ignored */
1557 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1558 Tcl_NewStringObj (reg_names
[regnum
], -1));
1561 /* This implements the tcl command gdb_fetch_registers
1562 * Pass it a list of register names, and it will
1563 * return their values as a list.
1566 * format: The format string for printing the values
1567 * args: the registers to look for
1569 * A list of their values.
1573 gdb_fetch_registers (clientData
, interp
, objc
, objv
)
1574 ClientData clientData
;
1577 Tcl_Obj
*CONST objv
[];
1583 Tcl_SetStringObj (result_ptr
->obj_ptr
,
1584 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
1588 format
= *(Tcl_GetStringFromObj(objv
[0], NULL
));
1592 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Output the results as a list */
1593 result
= map_arg_registers (objc
, objv
, get_register
, (void *) format
);
1594 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
1600 get_register (regnum
, fp
)
1604 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1605 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
1606 int format
= (int)fp
;
1611 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1613 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1614 Tcl_NewStringObj ("Optimized out", -1));
1618 /* Convert raw data to virtual format if necessary. */
1620 if (REGISTER_CONVERTIBLE (regnum
))
1622 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
1623 raw_buffer
, virtual_buffer
);
1626 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1631 printf_filtered ("0x");
1632 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1634 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1635 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1636 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
1640 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
1641 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1645 /* This implements the tcl command get_pc_reg
1646 * It returns the value of the PC register
1651 * The value of the pc register.
1655 get_pc_register (clientData
, interp
, objc
, objv
)
1656 ClientData clientData
;
1659 Tcl_Obj
*CONST objv
[];
1663 sprintf (buff
, "0x%llx",(long long) read_register (PC_REGNUM
));
1664 Tcl_SetStringObj(result_ptr
->obj_ptr
, buff
, -1);
1668 /* This implements the tcl command "gdb_changed_register_list"
1669 * It takes a list of registers, and returns a list of
1670 * the registers on that list that have changed since the last
1671 * time the proc was called.
1674 * A list of registers.
1676 * A list of changed registers.
1680 gdb_changed_register_list (clientData
, interp
, objc
, objv
)
1681 ClientData clientData
;
1684 Tcl_Obj
*CONST objv
[];
1689 return map_arg_registers (objc
, objv
, register_changed_p
, NULL
);
1693 register_changed_p (regnum
, argp
)
1695 void *argp
; /* Ignored */
1697 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1699 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1702 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1703 REGISTER_RAW_SIZE (regnum
)) == 0)
1706 /* Found a changed register. Save new value and return its number. */
1708 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1709 REGISTER_RAW_SIZE (regnum
));
1711 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(regnum
));
1715 * This section contains the commands that deal with tracepoints:
1718 /* return a list of all tracepoint numbers in interpreter */
1720 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
1721 ClientData clientData
;
1724 Tcl_Obj
*CONST objv
[];
1726 struct tracepoint
*tp
;
1728 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1730 ALL_TRACEPOINTS (tp
)
1731 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->number
));
1736 /* returns -1 if not found, tracepoint # if found */
1738 tracepoint_exists (char * args
)
1740 struct tracepoint
*tp
;
1742 struct symtabs_and_lines sals
;
1746 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1747 if (sals
.nelts
== 1)
1749 resolve_sal_pc (&sals
.sals
[0]);
1750 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
1751 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
1754 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
1755 strcat (file
, sals
.sals
[0].symtab
->filename
);
1757 ALL_TRACEPOINTS (tp
)
1759 if (tp
->address
== sals
.sals
[0].pc
)
1760 result
= tp
->number
;
1762 /* Why is this here? This messes up assembly traces */
1763 else if (tp
->source_file
!= NULL
1764 && strcmp (tp
->source_file
, file
) == 0
1765 && sals
.sals
[0].line
== tp
->line_number
)
1766 result
= tp
->number
;
1777 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
1778 ClientData clientData
;
1781 Tcl_Obj
*CONST objv
[];
1787 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1788 Tcl_GetStringFromObj (objv
[0], NULL
),
1789 " function:line|function|line|*addr\"", NULL
);
1793 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1795 Tcl_SetIntObj (result_ptr
->obj_ptr
, tracepoint_exists (args
));
1800 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
1801 ClientData clientData
;
1804 Tcl_Obj
*CONST objv
[];
1806 struct symtab_and_line sal
;
1808 struct tracepoint
*tp
;
1809 struct action_line
*al
;
1810 Tcl_Obj
*action_list
;
1811 char *filename
, *funcname
;
1816 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1820 if (Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
) != TCL_OK
)
1822 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1826 ALL_TRACEPOINTS (tp
)
1827 if (tp
->number
== tpnum
)
1832 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Tracepoint #%d does not exist", -1);
1836 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1837 sal
= find_pc_line (tp
->address
, 0);
1838 filename
= symtab_to_filename (sal
.symtab
);
1839 if (filename
== NULL
)
1841 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1842 Tcl_NewStringObj (filename
, -1));
1843 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
1844 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (funcname
, -1));
1845 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (sal
.line
));
1846 sprintf (tmp
, "0x%lx", tp
->address
);
1847 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (tmp
, -1));
1848 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->enabled
));
1849 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->pass_count
));
1850 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->step_count
));
1851 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->thread
));
1852 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->hit_count
));
1854 /* Append a list of actions */
1855 action_list
= Tcl_NewObj ();
1856 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
1858 Tcl_ListObjAppendElement (interp
, action_list
,
1859 Tcl_NewStringObj (al
->action
, -1));
1861 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, action_list
);
1868 gdb_trace_status (clientData
, interp
, objc
, objv
)
1869 ClientData clientData
;
1872 Tcl_Obj
*CONST objv
[];
1876 if (trace_running_p
)
1879 Tcl_SetIntObj (result_ptr
->obj_ptr
, result
);
1886 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
1887 ClientData clientData
;
1890 Tcl_Obj
*CONST objv
[];
1894 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1895 Tcl_GetStringFromObj (objv
[0], NULL
),
1896 " linespec\"", NULL
);
1900 Tcl_SetIntObj (result_ptr
->obj_ptr
, get_traceframe_number ());
1905 /* This implements the tcl command gdb_actions
1906 * It sets actions for a given tracepoint.
1909 * number: the tracepoint in question
1910 * actions: the actions to add to this tracepoint
1916 gdb_actions_command (clientData
, interp
, objc
, objv
)
1917 ClientData clientData
;
1920 Tcl_Obj
*CONST objv
[];
1922 struct tracepoint
*tp
;
1924 int nactions
, i
, len
;
1925 char *number
, *args
, *action
;
1927 struct action_line
*next
= NULL
, *temp
;
1928 enum actionline_type linetype
;
1932 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # args: should be: \"",
1933 Tcl_GetStringFromObj (objv
[0], NULL
),
1934 " number actions\"", NULL
);
1938 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
1939 tp
= get_tracepoint_by_number (&args
);
1942 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "Tracepoint \"", number
, "\" does not exist", NULL
);
1946 /* Free any existing actions */
1947 if (tp
->actions
!= NULL
)
1952 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
1954 /* Add the actions to the tracepoint */
1955 for (i
= 0; i
< nactions
; i
++)
1957 temp
= xmalloc (sizeof (struct action_line
));
1959 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
1960 temp
->action
= savestring (action
, len
);
1962 linetype
= validate_actionline (&(temp
->action
), tp
);
1964 if (linetype
== BADLINE
)
1986 * This section has commands that handle source disassembly.
1989 /* This implements the tcl command gdb_disassemble
1992 * source_with_assm - must be "source" or "nosource"
1993 * low_address - the address from which to start disassembly
1994 * ?hi_address? - the address to which to disassemble, defaults
1995 * to the end of the function containing low_address.
1997 * The disassembled code is passed to fputs_unfiltered, so it
1998 * either goes to the console if result_ptr->obj_ptr is NULL or to
2003 gdb_disassemble (clientData
, interp
, objc
, objv
)
2004 ClientData clientData
;
2007 Tcl_Obj
*CONST objv
[];
2009 CORE_ADDR pc
, low
, high
;
2010 int mixed_source_and_assembly
;
2011 static disassemble_info di
;
2012 static int di_initialized
;
2015 if (objc
!= 3 && objc
!= 4)
2016 error ("wrong # args");
2018 if (! di_initialized
)
2020 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
2021 (fprintf_ftype
) fprintf_unfiltered
);
2022 di
.flavour
= bfd_target_unknown_flavour
;
2023 di
.memory_error_func
= dis_asm_memory_error
;
2024 di
.print_address_func
= dis_asm_print_address
;
2028 di
.mach
= tm_print_insn_info
.mach
;
2029 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
2030 di
.endian
= BFD_ENDIAN_BIG
;
2032 di
.endian
= BFD_ENDIAN_LITTLE
;
2034 arg_ptr
= Tcl_GetStringFromObj (objv
[1], NULL
);
2035 if (*arg_ptr
== 's' && strcmp (arg_ptr
, "source") == 0)
2036 mixed_source_and_assembly
= 1;
2037 else if (*arg_ptr
== 'n' && strcmp (arg_ptr
, "nosource") == 0)
2038 mixed_source_and_assembly
= 0;
2040 error ("First arg must be 'source' or 'nosource'");
2042 low
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[2], NULL
));
2046 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
2047 error ("No function contains specified address");
2050 high
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[3], NULL
));
2052 /* If disassemble_from_exec == -1, then we use the following heuristic to
2053 determine whether or not to do disassembly from target memory or from the
2056 If we're debugging a local process, read target memory, instead of the
2057 exec file. This makes disassembly of functions in shared libs work
2060 Else, we're debugging a remote process, and should disassemble from the
2061 exec file for speed. However, this is no good if the target modifies its
2062 code (for relocation, or whatever).
2065 if (disassemble_from_exec
== -1)
2066 if (strcmp (target_shortname
, "child") == 0
2067 || strcmp (target_shortname
, "procfs") == 0
2068 || strcmp (target_shortname
, "vxprocess") == 0)
2069 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
2071 disassemble_from_exec
= 1; /* It's remote, read the exec file */
2073 if (disassemble_from_exec
)
2074 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
2076 di
.read_memory_func
= dis_asm_read_memory
;
2078 /* If just doing straight assembly, all we need to do is disassemble
2079 everything between low and high. If doing mixed source/assembly, we've
2080 got a totally different path to follow. */
2082 if (mixed_source_and_assembly
)
2083 { /* Come here for mixed source/assembly */
2084 /* The idea here is to present a source-O-centric view of a function to
2085 the user. This means that things are presented in source order, with
2086 (possibly) out of order assembly immediately following. */
2087 struct symtab
*symtab
;
2088 struct linetable_entry
*le
;
2091 struct my_line_entry
*mle
;
2092 struct symtab_and_line sal
;
2097 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
2102 /* First, convert the linetable to a bunch of my_line_entry's. */
2104 le
= symtab
->linetable
->item
;
2105 nlines
= symtab
->linetable
->nitems
;
2110 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
2114 /* Copy linetable entries for this function into our data structure, creating
2115 end_pc's and setting out_of_order as appropriate. */
2117 /* First, skip all the preceding functions. */
2119 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
2121 /* Now, copy all entries before the end of this function. */
2124 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
2126 if (le
[i
].line
== le
[i
+ 1].line
2127 && le
[i
].pc
== le
[i
+ 1].pc
)
2128 continue; /* Ignore duplicates */
2130 mle
[newlines
].line
= le
[i
].line
;
2131 if (le
[i
].line
> le
[i
+ 1].line
)
2133 mle
[newlines
].start_pc
= le
[i
].pc
;
2134 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
2138 /* If we're on the last line, and it's part of the function, then we need to
2139 get the end pc in a special way. */
2144 mle
[newlines
].line
= le
[i
].line
;
2145 mle
[newlines
].start_pc
= le
[i
].pc
;
2146 sal
= find_pc_line (le
[i
].pc
, 0);
2147 mle
[newlines
].end_pc
= sal
.end
;
2151 /* Now, sort mle by line #s (and, then by addresses within lines). */
2154 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
2156 /* Now, for each line entry, emit the specified lines (unless they have been
2157 emitted before), followed by the assembly code for that line. */
2159 next_line
= 0; /* Force out first line */
2160 for (i
= 0; i
< newlines
; i
++)
2162 /* Print out everything from next_line to the current line. */
2164 if (mle
[i
].line
>= next_line
)
2167 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
2169 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
2171 next_line
= mle
[i
].line
+ 1;
2174 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
2177 fputs_unfiltered (" ", gdb_stdout
);
2178 print_address (pc
, gdb_stdout
);
2179 fputs_unfiltered (":\t ", gdb_stdout
);
2180 pc
+= (*tm_print_insn
) (pc
, &di
);
2181 fputs_unfiltered ("\n", gdb_stdout
);
2188 for (pc
= low
; pc
< high
; )
2191 fputs_unfiltered (" ", gdb_stdout
);
2192 print_address (pc
, gdb_stdout
);
2193 fputs_unfiltered (":\t ", gdb_stdout
);
2194 pc
+= (*tm_print_insn
) (pc
, &di
);
2195 fputs_unfiltered ("\n", gdb_stdout
);
2199 gdb_flush (gdb_stdout
);
2204 /* This is the memory_read_func for gdb_disassemble when we are
2205 disassembling from the exec file. */
2208 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
2212 disassemble_info
*info
;
2214 extern struct target_ops exec_ops
;
2218 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
2229 /* This will be passed to qsort to sort the results of the disassembly */
2232 compare_lines (mle1p
, mle2p
)
2236 struct my_line_entry
*mle1
, *mle2
;
2239 mle1
= (struct my_line_entry
*) mle1p
;
2240 mle2
= (struct my_line_entry
*) mle2p
;
2242 val
= mle1
->line
- mle2
->line
;
2247 return mle1
->start_pc
- mle2
->start_pc
;
2250 /* This implements the TCL command `gdb_loc',
2253 * ?symbol? The symbol or address to locate - defaults to pc
2255 * a list consisting of the following:
2256 * basename, function name, filename, line number, address, current pc
2260 gdb_loc (clientData
, interp
, objc
, objv
)
2261 ClientData clientData
;
2264 Tcl_Obj
*CONST objv
[];
2267 struct symtab_and_line sal
;
2268 char *funcname
, *fname
;
2271 if (!have_full_symbols () && !have_partial_symbols ())
2273 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No symbol table is loaded", -1);
2279 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
2281 /* Note - this next line is not correct on all architectures. */
2282 /* For a graphical debugger we really want to highlight the */
2283 /* assembly line that called the next function on the stack. */
2284 /* Many architectures have the next instruction saved as the */
2285 /* pc on the stack, so what happens is the next instruction is hughlighted. */
2287 pc
= selected_frame
->pc
;
2288 sal
= find_pc_line (selected_frame
->pc
,
2289 selected_frame
->next
!= NULL
2290 && !selected_frame
->next
->signal_handler_caller
2291 && !frame_in_dummy (selected_frame
->next
));
2296 sal
= find_pc_line (stop_pc
, 0);
2301 struct symtabs_and_lines sals
;
2304 sals
= decode_line_spec (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
2310 if (sals
.nelts
!= 1)
2312 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Ambiguous line spec", -1);
2320 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
2325 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2326 Tcl_NewStringObj (sal
.symtab
->filename
, -1));
2328 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewStringObj ("", 0));
2330 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
2331 fname
= cplus_demangle (funcname
, 0);
2334 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2335 Tcl_NewStringObj (fname
, -1));
2339 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2340 Tcl_NewStringObj (funcname
, -1));
2342 filename
= symtab_to_filename (sal
.symtab
);
2343 if (filename
== NULL
)
2346 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2347 Tcl_NewStringObj (filename
, -1));
2348 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(sal
.line
)); /* line number */
2349 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
2350 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
2354 /* This implements the Tcl command 'gdb_get_mem', which
2355 * dumps a block of memory
2357 * gdb_get_mem addr form size num aschar
2359 * addr: address of data to dump
2360 * form: a char indicating format
2361 * size: size of each element; 1,2,4, or 8 bytes
2362 * num: the number of bytes to read
2363 * acshar: an optional ascii character to use in ASCII dump
2366 * a list of elements followed by an optional ASCII dump
2370 gdb_get_mem (clientData
, interp
, objc
, objv
)
2371 ClientData clientData
;
2374 Tcl_Obj
*CONST objv
[];
2376 int size
, asize
, i
, j
, bc
;
2378 int nbytes
, rnum
, bpr
;
2380 char format
, c
, *ptr
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
2381 struct type
*val_type
;
2383 if (objc
< 6 || objc
> 7)
2385 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2386 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2390 if (Tcl_GetIntFromObj (interp
, objv
[3], &size
) != TCL_OK
)
2392 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2397 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid size, must be > 0", -1);
2401 if (Tcl_GetIntFromObj (interp
, objv
[4], &nbytes
) != TCL_OK
)
2403 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2408 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid number of bytes, must be > 0",
2413 if (Tcl_GetIntFromObj (interp
, objv
[5], &bpr
) != TCL_OK
)
2415 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2420 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid bytes per row, must be > 0", -1);
2424 if (Tcl_GetLongFromObj (interp
, objv
[1], &tmp
) != TCL_OK
)
2427 addr
= (CORE_ADDR
) tmp
;
2429 format
= *(Tcl_GetStringFromObj (objv
[2], NULL
));
2430 mbuf
= (char *)malloc (nbytes
+32);
2433 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Out of memory.", -1);
2437 memset (mbuf
, 0, nbytes
+32);
2440 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
2443 aschar
= *(Tcl_GetStringFromObj(objv
[6], NULL
));
2449 val_type
= builtin_type_char
;
2453 val_type
= builtin_type_short
;
2457 val_type
= builtin_type_int
;
2461 val_type
= builtin_type_long_long
;
2465 val_type
= builtin_type_char
;
2469 bc
= 0; /* count of bytes in a row */
2470 buff
[0] = '"'; /* buffer for ascii dump */
2471 bptr
= &buff
[1]; /* pointer for ascii dump */
2473 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Build up the result as a list... */
2475 for (i
=0; i
< nbytes
; i
+= size
)
2479 fputs_unfiltered ("N/A ", gdb_stdout
);
2481 for ( j
= 0; j
< size
; j
++)
2486 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
2490 for ( j
= 0; j
< size
; j
++)
2493 if (c
< 32 || c
> 126)
2505 if (aschar
&& (bc
>= bpr
))
2507 /* end of row. print it and reset variables */
2512 fputs_unfiltered (buff
, gdb_stdout
);
2517 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
2525 /* This implements the tcl command "gdb_loadfile"
2526 * It loads a c source file into a text widget.
2529 * widget: the name of the text widget to fill
2530 * filename: the name of the file to load
2531 * linenumbers: A boolean indicating whether or not to display line numbers.
2536 /* In this routine, we will build up a "line table", i.e. a
2537 * table of bits showing which lines in the source file are executible.
2538 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2540 * Its size limits the maximum number of lines
2541 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2542 * the file is loaded, so it is OK to make this very large.
2543 * Additional memory will be allocated if needed. */
2544 #define LTABLE_SIZE 20000
2546 gdb_loadfile (clientData
, interp
, objc
, objv
)
2547 ClientData clientData
;
2550 Tcl_Obj
*CONST objv
[];
2552 char *file
, *widget
, *buf
, msg
[128];
2553 int linenumbers
, ln
, anum
, lnum
, ltable_size
;
2556 struct symtab
*symtab
;
2557 struct linetable_entry
*le
;
2560 Tcl_DString text_cmd_1
, text_cmd_2
, *cur_cmd
;
2561 char line
[1024], line_num_buf
[16];
2562 int prefix_len_1
, prefix_len_2
, cur_prefix_len
, widget_len
;
2567 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
2571 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
2572 if ( Tk_NameToWindow (interp
, widget
, Tk_MainWindow (interp
)) == NULL
)
2577 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
2578 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
2580 if ((fp
= fopen ( file
, "r" )) == NULL
)
2582 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Can't open file for reading", -1);
2586 symtab
= full_lookup_symtab (file
);
2589 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "File not found in symtab", -1);
2594 if (stat (file
, &st
) < 0)
2596 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
2601 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
2602 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
2604 mtime
= bfd_get_mtime(exec_bfd
);
2606 if (mtime
&& mtime
< st
.st_mtime
)
2607 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2610 /* Source linenumbers don't appear to be in order, and a sort is */
2611 /* too slow so the fastest solution is just to allocate a huge */
2612 /* array and set the array entry for each linenumber */
2614 ltable_size
= LTABLE_SIZE
;
2615 ltable
= (char *)malloc (LTABLE_SIZE
);
2618 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2623 memset (ltable
, 0, LTABLE_SIZE
);
2625 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
2627 le
= symtab
->linetable
->item
;
2628 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
2630 lnum
= le
->line
>> 3;
2631 if (lnum
>= ltable_size
)
2634 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
2635 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
2637 if (new_ltable
== NULL
)
2639 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2644 ltable
= new_ltable
;
2646 ltable
[lnum
] |= 1 << (le
->line
% 8);
2650 Tcl_DStringInit(&text_cmd_1
);
2651 Tcl_DStringInit(&text_cmd_2
);
2655 widget_len
= strlen (widget
);
2658 Tcl_DStringAppend (&text_cmd_1
, widget
, widget_len
);
2659 Tcl_DStringAppend (&text_cmd_2
, widget
, widget_len
);
2663 Tcl_DStringAppend (&text_cmd_1
, " insert end {-\t", -1);
2664 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2666 Tcl_DStringAppend (&text_cmd_2
, " insert end { \t", -1);
2667 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2669 while (fgets (line
+ 1, 980, fp
))
2671 sprintf (line_num_buf
, "%d", ln
);
2672 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2674 cur_cmd
= &text_cmd_1
;
2675 cur_prefix_len
= prefix_len_1
;
2676 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2677 Tcl_DStringAppend (cur_cmd
, "} break_tag", 11);
2681 cur_cmd
= &text_cmd_2
;
2682 cur_prefix_len
= prefix_len_2
;
2683 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2684 Tcl_DStringAppend (cur_cmd
, "} \"\"", 4);
2687 Tcl_DStringAppendElement (cur_cmd
, line
);
2688 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2690 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2691 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2697 Tcl_DStringAppend (&text_cmd_1
, " insert end {- } break_tag", -1);
2698 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2699 Tcl_DStringAppend (&text_cmd_2
, " insert end { } \"\"", -1);
2700 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2703 while (fgets (line
+ 1, 980, fp
))
2705 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2707 cur_cmd
= &text_cmd_1
;
2708 cur_prefix_len
= prefix_len_1
;
2712 cur_cmd
= &text_cmd_2
;
2713 cur_prefix_len
= prefix_len_2
;
2716 Tcl_DStringAppendElement (cur_cmd
, line
);
2717 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2719 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2720 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2726 Tcl_DStringFree (&text_cmd_1
);
2727 Tcl_DStringFree (&text_cmd_2
);
2734 * This section contains commands for manipulation of breakpoints.
2738 /* set a breakpoint by source file and line number */
2739 /* flags are as follows: */
2740 /* least significant 2 bits are disposition, rest is */
2741 /* type (normally 0).
2744 bp_breakpoint, Normal breakpoint
2745 bp_hardware_breakpoint, Hardware assisted breakpoint
2748 Disposition of breakpoint. Ie: what to do after hitting it.
2751 del_at_next_stop, Delete at next stop, whether hit or not
2753 donttouch Leave it alone
2757 /* This implements the tcl command "gdb_set_bp"
2758 * It sets breakpoints, and runs the Tcl command
2759 * gdbtk_tcl_breakpoint create
2760 * to register the new breakpoint with the GUI.
2763 * filename: the file in which to set the breakpoint
2764 * line: the line number for the breakpoint
2765 * type: the type of the breakpoint
2767 * The return value of the call to gdbtk_tcl_breakpoint.
2771 gdb_set_bp (clientData
, interp
, objc
, objv
)
2772 ClientData clientData
;
2775 Tcl_Obj
*CONST objv
[];
2778 struct symtab_and_line sal
;
2779 int line
, flags
, ret
;
2780 struct breakpoint
*b
;
2786 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
2790 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
2791 if (sal
.symtab
== NULL
)
2794 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
2796 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2800 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
2802 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2807 if (!find_line_pc (sal
.symtab
, sal
.line
, &sal
.pc
))
2810 sal
.section
= find_pc_overlay (sal
.pc
);
2811 b
= set_raw_breakpoint (sal
);
2812 set_breakpoint_count (breakpoint_count
+ 1);
2813 b
->number
= breakpoint_count
;
2814 b
->type
= flags
>> 2;
2815 b
->disposition
= flags
& 3;
2817 /* FIXME: this won't work for duplicate basenames! */
2818 sprintf (buf
, "%s:%d", basename (Tcl_GetStringFromObj ( objv
[1], NULL
)), line
);
2819 b
->addr_string
= strsave (buf
);
2821 /* now send notification command back to GUI */
2823 Tcl_DStringInit (&cmd
);
2825 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2826 sprintf (buf
, "%d", b
->number
);
2827 Tcl_DStringAppendElement(&cmd
, buf
);
2828 sprintf (buf
, "0x%x", sal
.pc
);
2829 Tcl_DStringAppendElement (&cmd
, buf
);
2830 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[2], NULL
));
2831 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[1], NULL
));
2833 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2834 Tcl_DStringFree (&cmd
);
2838 /* This implements the tcl command gdb_get_breakpoint_info
2844 * A list with {file, function, line_number, address, type, enabled?,
2845 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
2849 gdb_get_breakpoint_info (clientData
, interp
, objc
, objv
)
2850 ClientData clientData
;
2853 Tcl_Obj
*CONST objv
[];
2855 struct symtab_and_line sal
;
2856 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
2857 "finish", "watchpoint", "hardware watchpoint",
2858 "read watchpoint", "access watchpoint",
2859 "longjmp", "longjmp resume", "step resume",
2860 "through sigtramp", "watchpoint scope",
2862 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
2863 struct command_line
*cmd
;
2865 struct breakpoint
*b
;
2866 extern struct breakpoint
*breakpoint_chain
;
2867 char *funcname
, *fname
, *filename
;
2872 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong number of args, should be \"breakpoint\"", -1);
2876 if ( Tcl_GetIntFromObj(NULL
, objv
[1], &bpnum
) != TCL_OK
)
2878 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2882 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2883 if (b
->number
== bpnum
)
2886 if (!b
|| b
->type
!= bp_breakpoint
)
2888 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Breakpoint #%d does not exist", -1);
2892 sal
= find_pc_line (b
->address
, 0);
2894 filename
= symtab_to_filename (sal
.symtab
);
2895 if (filename
== NULL
)
2898 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
2899 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2900 Tcl_NewStringObj (filename
, -1));
2902 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
2903 fname
= cplus_demangle (funcname
, 0);
2906 new_obj
= Tcl_NewStringObj (fname
, -1);
2910 new_obj
= Tcl_NewStringObj (funcname
, -1);
2912 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2914 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->line_number
));
2915 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%lx", b
->address
);
2916 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2917 Tcl_NewStringObj (bptypes
[b
->type
], -1));
2918 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewBooleanObj(b
->enable
== enabled
));
2919 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2920 Tcl_NewStringObj (bpdisp
[b
->disposition
], -1));
2921 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->ignore_count
));
2923 new_obj
= Tcl_NewObj();
2924 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
2925 Tcl_ListObjAppendElement (NULL
, new_obj
,
2926 Tcl_NewStringObj (cmd
->line
, -1));
2927 Tcl_ListObjAppendElement(NULL
, result_ptr
->obj_ptr
, new_obj
);
2929 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2930 Tcl_NewStringObj (b
->cond_string
, -1));
2932 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->thread
));
2933 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->hit_count
));
2939 /* This implements the tcl command gdb_get_breakpoint_list
2940 * It builds up a list of the current breakpoints.
2945 * A list of breakpoint numbers.
2949 gdb_get_breakpoint_list (clientData
, interp
, objc
, objv
)
2950 ClientData clientData
;
2953 Tcl_Obj
*CONST objv
[];
2955 struct breakpoint
*b
;
2956 extern struct breakpoint
*breakpoint_chain
;
2960 error ("wrong number of args, none are allowed");
2962 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2963 if (b
->type
== bp_breakpoint
)
2965 new_obj
= Tcl_NewIntObj (b
->number
);
2966 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2974 * This section contains a bunch of miscellaneous utility commands
2977 /* This implements the tcl command gdb_path_conv
2979 * On Windows, it canonicalizes the pathname,
2980 * On Unix, it is a no op.
2985 * The canonicalized path.
2989 gdb_path_conv (clientData
, interp
, objc
, objv
)
2990 ClientData clientData
;
2993 Tcl_Obj
*CONST objv
[];
2996 error ("wrong # args");
3000 char pathname
[256], *ptr
;
3002 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj(objv
[1], NULL
), pathname
);
3003 for (ptr
= pathname
; *ptr
; ptr
++)
3008 Tcl_SetStringObj (result_ptr
->obj_ptr
, pathname
, -1);
3011 Tcl_SetStringObj (result_ptr
->obj_ptr
, Tcl_GetStringFromObj (objv
[1], NULL
), -1);
3018 * This section has utility routines that are not Tcl commands.
3022 perror_with_name_wrapper (args
)
3025 perror_with_name (args
);
3029 /* The lookup_symtab() in symtab.c doesn't work correctly */
3030 /* It will not work will full pathnames and if multiple */
3031 /* source files have the same basename, it will return */
3032 /* the first one instead of the correct one. This version */
3033 /* also always makes sure symtab->fullname is set. */
3035 static struct symtab
*
3036 full_lookup_symtab(file
)
3040 struct objfile
*objfile
;
3041 char *bfile
, *fullname
;
3042 struct partial_symtab
*pt
;
3047 /* first try a direct lookup */
3048 st
= lookup_symtab (file
);
3052 symtab_to_filename(st
);
3056 /* if the direct approach failed, try */
3057 /* looking up the basename and checking */
3058 /* all matches with the fullname */
3059 bfile
= basename (file
);
3060 ALL_SYMTABS (objfile
, st
)
3062 if (!strcmp (bfile
, basename(st
->filename
)))
3065 fullname
= symtab_to_filename (st
);
3067 fullname
= st
->fullname
;
3069 if (!strcmp (file
, fullname
))
3074 /* still no luck? look at psymtabs */
3075 ALL_PSYMTABS (objfile
, pt
)
3077 if (!strcmp (bfile
, basename(pt
->filename
)))
3079 st
= PSYMTAB_TO_SYMTAB (pt
);
3082 fullname
= symtab_to_filename (st
);
3083 if (!strcmp (file
, fullname
))