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
];
134 /* These two lookup tables are used to translate the type & disposition fields
135 of the breakpoint structure (respectively) into something gdbtk understands.
136 They are also used in gdbtk-hooks.c */
138 char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
139 "finish", "watchpoint", "hardware watchpoint",
140 "read watchpoint", "access watchpoint",
141 "longjmp", "longjmp resume", "step resume",
142 "through sigtramp", "watchpoint scope",
144 char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
147 * These are routines we need from breakpoint.c.
148 * at some point make these static in breakpoint.c and move GUI code there
151 extern struct breakpoint
*set_raw_breakpoint (struct symtab_and_line sal
);
152 extern void set_breakpoint_count (int);
153 extern int breakpoint_count
;
155 /* This variable determines where memory used for disassembly is read from.
156 * See note in gdbtk.h for details.
158 int disassemble_from_exec
= -1;
162 * Declarations for routines exported from this file
165 int Gdbtk_Init (Tcl_Interp
*interp
);
168 * Declarations for routines used only in this file.
171 static int compare_lines
PARAMS ((const PTR
, const PTR
));
172 static int comp_files
PARAMS ((const void *, const void *));
173 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
174 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
175 Tcl_Obj
*CONST objv
[]));
176 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
177 static int gdb_clear_file
PARAMS ((ClientData
, Tcl_Interp
*interp
, int, Tcl_Obj
*CONST
[]));
178 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
179 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
180 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int,
182 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
183 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
184 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
185 Tcl_Obj
*CONST objv
[]));
186 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
187 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
188 static int gdb_get_args_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
189 Tcl_Obj
*CONST objv
[]));
190 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
191 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
192 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
193 Tcl_Obj
*CONST objv
[]));
194 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
195 Tcl_Obj
*CONST objv
[]));
196 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
197 Tcl_Obj
*CONST objv
[]));
198 static int gdb_get_locals_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
199 Tcl_Obj
*CONST objv
[]));
200 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
201 static int gdb_get_trace_frame_num
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
202 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int,
203 Tcl_Obj
*CONST objv
[]));
204 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
205 Tcl_Obj
*CONST objv
[]));
206 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
207 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
208 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
209 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
210 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
211 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
212 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
213 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
214 Tcl_Obj
*CONST objv
[]));
215 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
216 static int gdb_search
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
218 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
219 static int gdb_set_bp_addr
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
220 static int gdb_find_bp_at_line
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
221 static int gdb_find_bp_at_addr
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
222 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
223 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*,
226 static int gdb_trace_status
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
227 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*,
229 Tcl_Obj
*CONST objv
[]));
230 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int,
231 Tcl_Obj
*CONST objv
[]));
232 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
233 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
234 static int gdb_stack
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
236 char * get_prompt
PARAMS ((void));
237 static void get_register
PARAMS ((int, void *));
238 static void get_register_name
PARAMS ((int, void *));
239 static int map_arg_registers
PARAMS ((int, Tcl_Obj
*CONST
[], void (*) (int, void *), void *));
240 static int perror_with_name_wrapper
PARAMS ((char *args
));
241 static void register_changed_p
PARAMS ((int, void *));
242 void TclDebug
PARAMS ((const char *fmt
, ...));
243 static int wrapped_call (char *opaque_args
);
244 static void get_frame_name
PARAMS ((Tcl_Interp
*interp
, Tcl_Obj
*list
, struct frame_info
*fi
));
247 * This loads all the Tcl commands into the Tcl interpreter.
250 * interp - The interpreter into which to load the commands.
253 * A standard Tcl result.
260 Tcl_CreateObjCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
261 Tcl_CreateObjCommand (interp
, "gdb_immediate", call_wrapper
,
262 gdb_immediate_command
, NULL
);
263 Tcl_CreateObjCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
264 Tcl_CreateObjCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
265 Tcl_CreateObjCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
, NULL
);
266 Tcl_CreateObjCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
268 Tcl_CreateObjCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
270 Tcl_CreateObjCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
271 Tcl_CreateObjCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
272 Tcl_CreateObjCommand (interp
, "gdb_fetch_registers", call_wrapper
,
273 gdb_fetch_registers
, NULL
);
274 Tcl_CreateObjCommand (interp
, "gdb_changed_register_list", call_wrapper
,
275 gdb_changed_register_list
, NULL
);
276 Tcl_CreateObjCommand (interp
, "gdb_disassemble", call_wrapper
,
277 gdb_disassemble
, NULL
);
278 Tcl_CreateObjCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
279 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
280 gdb_get_breakpoint_list
, NULL
);
281 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
282 gdb_get_breakpoint_info
, NULL
);
283 Tcl_CreateObjCommand (interp
, "gdb_clear_file", call_wrapper
,
284 gdb_clear_file
, NULL
);
285 Tcl_CreateObjCommand (interp
, "gdb_confirm_quit", call_wrapper
,
286 gdb_confirm_quit
, NULL
);
287 Tcl_CreateObjCommand (interp
, "gdb_force_quit", call_wrapper
,
288 gdb_force_quit
, NULL
);
289 Tcl_CreateObjCommand (interp
, "gdb_target_has_execution",
291 gdb_target_has_execution_command
, NULL
);
292 Tcl_CreateObjCommand (interp
, "gdb_is_tracing",
293 call_wrapper
, gdb_trace_status
,
295 Tcl_CreateObjCommand (interp
, "gdb_load_info", call_wrapper
, gdb_load_info
, NULL
);
296 Tcl_CreateObjCommand (interp
, "gdb_get_locals", call_wrapper
, gdb_get_locals_command
,
298 Tcl_CreateObjCommand (interp
, "gdb_get_args", call_wrapper
, gdb_get_args_command
,
300 Tcl_CreateObjCommand (interp
, "gdb_get_function", call_wrapper
, gdb_get_function_command
,
302 Tcl_CreateObjCommand (interp
, "gdb_get_line", call_wrapper
, gdb_get_line_command
,
304 Tcl_CreateObjCommand (interp
, "gdb_get_file", call_wrapper
, gdb_get_file_command
,
306 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
307 call_wrapper
, gdb_tracepoint_exists_command
, NULL
);
308 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
309 call_wrapper
, gdb_get_tracepoint_info
, NULL
);
310 Tcl_CreateObjCommand (interp
, "gdb_actions",
311 call_wrapper
, gdb_actions_command
, NULL
);
312 Tcl_CreateObjCommand (interp
, "gdb_prompt",
313 call_wrapper
, gdb_prompt_command
, NULL
);
314 Tcl_CreateObjCommand (interp
, "gdb_find_file",
315 call_wrapper
, gdb_find_file_command
, NULL
);
316 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
317 call_wrapper
, gdb_get_tracepoint_list
, NULL
);
318 Tcl_CreateObjCommand (interp
, "gdb_pc_reg", call_wrapper
, get_pc_register
, NULL
);
319 Tcl_CreateObjCommand (interp
, "gdb_loadfile", call_wrapper
, gdb_loadfile
, NULL
);
320 Tcl_CreateObjCommand (gdbtk_interp
, "gdb_search", call_wrapper
,
322 Tcl_CreateObjCommand (interp
, "gdb_set_bp", call_wrapper
, gdb_set_bp
, NULL
);
323 Tcl_CreateObjCommand (interp
, "gdb_set_bp_addr", call_wrapper
, gdb_set_bp_addr
, NULL
);
324 Tcl_CreateObjCommand (interp
, "gdb_find_bp_at_line", call_wrapper
, gdb_find_bp_at_line
, NULL
);
325 Tcl_CreateObjCommand (interp
, "gdb_find_bp_at_addr", call_wrapper
, gdb_find_bp_at_addr
, NULL
);
326 Tcl_CreateObjCommand (interp
, "gdb_get_trace_frame_num",
327 call_wrapper
, gdb_get_trace_frame_num
, NULL
);
328 Tcl_CreateObjCommand (interp
, "gdb_stack", call_wrapper
, gdb_stack
, NULL
);
330 Tcl_LinkVar (interp
, "gdb_selected_frame_level",
331 (char *) &selected_frame_level
,
332 TCL_LINK_INT
| TCL_LINK_READ_ONLY
);
334 /* gdb_context is used for debugging multiple threads or tasks */
335 Tcl_LinkVar (interp
, "gdb_context_id",
336 (char *) &gdb_context
,
337 TCL_LINK_INT
| TCL_LINK_READ_ONLY
);
339 /* Determine where to disassemble from */
340 Tcl_LinkVar (gdbtk_interp
, "disassemble-from-exec", (char *) &disassemble_from_exec
,
343 Tcl_PkgProvide(interp
, "Gdbtk", GDBTK_VERSION
);
347 /* This routine acts as a top-level for all GDB code called by Tcl/Tk. It
348 handles cleanups, and uses catch_errors to trap calls to return_to_top_level
350 This is necessary in order to prevent a longjmp out of the bowels of Tk,
351 possibly leaving things in a bad state. Since this routine can be called
352 recursively, it needs to save and restore the contents of the result_ptr as
356 call_wrapper (clientData
, interp
, objc
, objv
)
357 ClientData clientData
;
360 Tcl_Obj
*CONST objv
[];
362 struct wrapped_call_args wrapped_args
;
363 gdbtk_result new_result
, *old_result_ptr
;
365 old_result_ptr
= result_ptr
;
366 result_ptr
= &new_result
;
367 result_ptr
->obj_ptr
= Tcl_NewObj();
368 result_ptr
->flags
= GDBTK_TO_RESULT
;
370 wrapped_args
.func
= (Tcl_ObjCmdProc
*) clientData
;
371 wrapped_args
.interp
= interp
;
372 wrapped_args
.objc
= objc
;
373 wrapped_args
.objv
= objv
;
374 wrapped_args
.val
= TCL_OK
;
376 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
379 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
381 /* Make sure the timer interrupts are turned off. */
385 gdb_flush (gdb_stderr
); /* Flush error output */
386 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
388 /* If we errored out here, and the results were going to the
389 console, then gdbtk_fputs will have gathered the result into the
390 result_ptr. We also need to echo them out to the console here */
392 gdb_flush (gdb_stderr
); /* Flush error output */
393 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
395 /* In case of an error, we may need to force the GUI into idle
396 mode because gdbtk_call_command may have bombed out while in
397 the command routine. */
400 Tcl_Eval (interp
, "gdbtk_tcl_idle");
404 /* do not suppress any errors -- a remote target could have errored */
405 load_in_progress
= 0;
408 * Now copy the result over to the true Tcl result. If GDBTK_TO_RESULT flag
409 * bit is set , this just copies a null object over to the Tcl result, which is
410 * fine because we should reset the result in this case anyway.
412 if (result_ptr
->flags
& GDBTK_IN_TCL_RESULT
)
414 Tcl_DecrRefCount(result_ptr
->obj_ptr
);
418 Tcl_SetObjResult (interp
, result_ptr
->obj_ptr
);
421 result_ptr
= old_result_ptr
;
427 return wrapped_args
.val
;
431 * This is the wrapper that is passed to catch_errors.
435 wrapped_call (opaque_args
)
438 struct wrapped_call_args
*args
= (struct wrapped_call_args
*) opaque_args
;
439 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->objc
, args
->objv
);
443 /* This is a convenience function to sprintf something(s) into a
444 * new element in a Tcl list object.
448 #ifdef ANSI_PROTOTYPES
449 sprintf_append_element_to_obj (Tcl_Obj
*objp
, char *format
, ...)
451 sprintf_append_element_to_obj (va_alist
)
458 #ifdef ANSI_PROTOTYPES
459 va_start (args
, format
);
465 dsp
= va_arg (args
, Tcl_Obj
*);
466 format
= va_arg (args
, char *);
469 vsprintf (buf
, format
, args
);
471 Tcl_ListObjAppendElement (NULL
, objp
, Tcl_NewStringObj (buf
, -1));
475 * This section contains the commands that control execution.
478 /* This implements the tcl command gdb_clear_file.
480 * Prepare to accept a new executable file. This is called when we
481 * want to clear away everything we know about the old file, without
482 * asking the user. The Tcl code will have already asked the user if
483 * necessary. After this is called, we should be able to run the
484 * `file' command without getting any questions.
493 gdb_clear_file (clientData
, interp
, objc
, objv
)
494 ClientData clientData
;
497 Tcl_Obj
*CONST objv
[];
500 Tcl_SetStringObj (result_ptr
->obj_ptr
,
501 "Wrong number of args, none are allowed.", -1);
503 if (inferior_pid
!= 0 && target_has_execution
)
506 target_detach (NULL
, 0);
511 if (target_has_execution
)
514 symbol_file_command (NULL
, 0);
516 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
517 clear it here. FIXME: This seems like an abstraction violation
524 /* This implements the tcl command gdb_confirm_quit
525 * Ask the user to confirm an exit request.
530 * A boolean, 1 if the user answered yes, 0 if no.
534 gdb_confirm_quit (clientData
, interp
, objc
, objv
)
535 ClientData clientData
;
538 Tcl_Obj
*CONST objv
[];
544 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
548 ret
= quit_confirm ();
549 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, ret
);
553 /* This implements the tcl command gdb_force_quit
554 * Quit without asking for confirmation.
563 gdb_force_quit (clientData
, interp
, objc
, objv
)
564 ClientData clientData
;
567 Tcl_Obj
*CONST objv
[];
571 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
575 quit_force ((char *) NULL
, 1);
579 /* This implements the tcl command gdb_stop
580 * It stops the target in a continuable fashion.
589 gdb_stop (clientData
, interp
, objc
, objv
)
590 ClientData clientData
;
593 Tcl_Obj
*CONST objv
[];
595 if (target_stop
!= target_ignore
)
598 quit_flag
= 1; /* hope something sees this */
605 * This section contains Tcl commands that are wrappers for invoking
606 * the GDB command interpreter.
610 /* This implements the tcl command `gdb_eval'.
611 * It uses the gdb evaluator to return the value of
612 * an expression in the current language
615 * expression - the expression to evaluate.
617 * The result of the evaluation.
621 gdb_eval (clientData
, interp
, objc
, objv
)
622 ClientData clientData
;
625 Tcl_Obj
*CONST objv
[];
627 struct expression
*expr
;
628 struct cleanup
*old_chain
=NULL
;
633 Tcl_SetStringObj (result_ptr
->obj_ptr
,
634 "wrong # args, should be \"gdb_eval expression\"", -1);
638 expr
= parse_expression (Tcl_GetStringFromObj (objv
[1], NULL
));
640 old_chain
= make_cleanup ((make_cleanup_func
) free_current_contents
, &expr
);
642 val
= evaluate_expression (expr
);
645 * Print the result of the expression evaluation. This will go to
646 * eventually go to gdbtk_fputs, and from there be collected into
650 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
),
651 VALUE_EMBEDDED_OFFSET(val
), VALUE_ADDRESS (val
),
652 gdb_stdout
, 0, 0, 0, 0);
654 do_cleanups (old_chain
);
659 /* This implements the tcl command "gdb_cmd".
661 * It sends its argument to the GDB command scanner for execution.
662 * This command will never cause the update, idle and busy hooks to be called
666 * command - The GDB command to execute
668 * The output from the gdb command (except for the "load" & "while"
669 * which dump their output to the console.
673 gdb_cmd (clientData
, interp
, objc
, objv
)
674 ClientData clientData
;
677 Tcl_Obj
*CONST objv
[];
683 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
689 if (Tcl_GetBooleanFromObj (NULL
, objv
[2], &from_tty
) != TCL_OK
) {
690 Tcl_SetStringObj (result_ptr
->obj_ptr
, "from_tty must be a boolean.",
696 if (running_now
|| load_in_progress
)
701 /* for the load instruction (and possibly others later) we
702 set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
703 will not buffer all the data until the command is finished. */
705 if ((strncmp ("load ", Tcl_GetStringFromObj (objv
[1], NULL
), 5) == 0))
707 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
708 load_in_progress
= 1;
711 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), from_tty
);
713 if (load_in_progress
)
715 load_in_progress
= 0;
716 result_ptr
->flags
|= GDBTK_TO_RESULT
;
719 bpstat_do_actions (&stop_bpstat
);
725 * This implements the tcl command "gdb_immediate"
727 * It does exactly the same thing as gdb_cmd, except NONE of its outut
728 * is buffered. This will also ALWAYS cause the busy, update, and idle hooks to
729 * be called, contrasted with gdb_cmd, which NEVER calls them.
730 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
731 * to the console window.
734 * command - The GDB command to execute
740 gdb_immediate_command (clientData
, interp
, objc
, objv
)
741 ClientData clientData
;
744 Tcl_Obj
*CONST objv
[];
749 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
753 if (running_now
|| load_in_progress
)
758 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
760 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
762 bpstat_do_actions (&stop_bpstat
);
764 result_ptr
->flags
|= GDBTK_TO_RESULT
;
769 /* This implements the tcl command "gdb_prompt"
771 * It returns the gdb interpreter's prompt.
780 gdb_prompt_command (clientData
, interp
, objc
, objv
)
781 ClientData clientData
;
784 Tcl_Obj
*CONST objv
[];
786 Tcl_SetStringObj (result_ptr
->obj_ptr
, get_prompt (), -1);
792 * This section contains general informational commands.
795 /* This implements the tcl command "gdb_target_has_execution"
797 * Tells whether the target is executing.
802 * A boolean indicating whether the target is executing.
806 gdb_target_has_execution_command (clientData
, interp
, objc
, objv
)
807 ClientData clientData
;
810 Tcl_Obj
*CONST objv
[];
814 if (target_has_execution
&& inferior_pid
!= 0)
817 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, result
);
821 /* This implements the tcl command "gdb_load_info"
823 * It returns information about the file about to be downloaded.
826 * filename: The file to open & get the info on.
828 * A list consisting of the name and size of each section.
832 gdb_load_info (clientData
, interp
, objc
, objv
)
833 ClientData clientData
;
836 Tcl_Obj
*CONST objv
[];
839 struct cleanup
*old_cleanups
;
843 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
845 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
846 if (loadfile_bfd
== NULL
)
848 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Open failed", -1);
851 old_cleanups
= make_cleanup ((make_cleanup_func
) bfd_close
, loadfile_bfd
);
853 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
855 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Bad Object File", -1);
859 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
861 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
863 if (s
->flags
& SEC_LOAD
)
865 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
868 ob
[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd
, s
), -1);
869 ob
[1] = Tcl_NewLongObj ((long) size
);
870 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewListObj (2, ob
));
875 do_cleanups (old_cleanups
);
881 * This and gdb_get_locals just call gdb_get_vars_command with the right
882 * value of clientData. We can't use the client data in the definition
883 * of the command, because the call wrapper uses this instead...
887 gdb_get_locals_command (clientData
, interp
, objc
, objv
)
888 ClientData clientData
;
891 Tcl_Obj
*CONST objv
[];
894 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
899 gdb_get_args_command (clientData
, interp
, objc
, objv
)
900 ClientData clientData
;
903 Tcl_Obj
*CONST objv
[];
906 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
910 /* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
912 * This function sets the Tcl interpreter's result to a list of variable names
913 * depending on clientData. If clientData is one, the result is a list of
914 * arguments; zero returns a list of locals -- all relative to the block
915 * specified as an argument to the command. Valid commands include
916 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
920 * block - the address within which to specify the locals or args.
922 * A list of the locals or args
926 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
927 ClientData clientData
;
930 Tcl_Obj
*CONST objv
[];
932 struct symtabs_and_lines sals
;
935 char **canonical
, *args
;
936 int i
, nsyms
, arguments
;
940 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
,
941 "wrong # of args: should be \"",
942 Tcl_GetStringFromObj (objv
[0], NULL
),
943 " function:line|function|line|*addr\"", NULL
);
947 arguments
= (int) clientData
;
948 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
949 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
952 Tcl_SetStringObj (result_ptr
->obj_ptr
,
953 "error decoding line", -1);
957 /* Initialize the result pointer to an empty list. */
959 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
961 /* Resolve all line numbers to PC's */
962 for (i
= 0; i
< sals
.nelts
; i
++)
963 resolve_sal_pc (&sals
.sals
[i
]);
965 block
= block_for_pc (sals
.sals
[0].pc
);
968 nsyms
= BLOCK_NSYMS (block
);
969 for (i
= 0; i
< nsyms
; i
++)
971 sym
= BLOCK_SYM (block
, i
);
972 switch (SYMBOL_CLASS (sym
)) {
974 case LOC_UNDEF
: /* catches errors */
975 case LOC_CONST
: /* constant */
976 case LOC_TYPEDEF
: /* local typedef */
977 case LOC_LABEL
: /* local label */
978 case LOC_BLOCK
: /* local function */
979 case LOC_CONST_BYTES
: /* loc. byte seq. */
980 case LOC_UNRESOLVED
: /* unresolved static */
981 case LOC_OPTIMIZED_OUT
: /* optimized out */
983 case LOC_ARG
: /* argument */
984 case LOC_REF_ARG
: /* reference arg */
985 case LOC_REGPARM
: /* register arg */
986 case LOC_REGPARM_ADDR
: /* indirect register arg */
987 case LOC_LOCAL_ARG
: /* stack arg */
988 case LOC_BASEREG_ARG
: /* basereg arg */
990 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
991 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
993 case LOC_LOCAL
: /* stack local */
994 case LOC_BASEREG
: /* basereg local */
995 case LOC_STATIC
: /* static */
996 case LOC_REGISTER
: /* register */
998 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
999 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
1003 if (BLOCK_FUNCTION (block
))
1006 block
= BLOCK_SUPERBLOCK (block
);
1012 /* This implements the tcl command "gdb_get_line"
1014 * It returns the linenumber for a given linespec. It will take any spec
1015 * that can be passed to decode_line_1
1018 * linespec - the line specification
1020 * The line number for that spec.
1023 gdb_get_line_command (clientData
, interp
, objc
, objv
)
1024 ClientData clientData
;
1027 Tcl_Obj
*CONST objv
[];
1029 struct symtabs_and_lines sals
;
1030 char *args
, **canonical
;
1034 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1035 Tcl_GetStringFromObj (objv
[0], NULL
),
1036 " linespec\"", NULL
);
1040 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1041 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1042 if (sals
.nelts
== 1)
1044 Tcl_SetIntObj (result_ptr
->obj_ptr
, sals
.sals
[0].line
);
1048 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1053 /* This implements the tcl command "gdb_get_file"
1055 * It returns the file containing a given line spec.
1058 * linespec - The linespec to look up
1060 * The file containing it.
1064 gdb_get_file_command (clientData
, interp
, objc
, objv
)
1065 ClientData clientData
;
1068 Tcl_Obj
*CONST objv
[];
1070 struct symtabs_and_lines sals
;
1071 char *args
, **canonical
;
1075 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1076 Tcl_GetStringFromObj (objv
[0], NULL
),
1077 " linespec\"", NULL
);
1081 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1082 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1083 if (sals
.nelts
== 1)
1085 Tcl_SetStringObj (result_ptr
->obj_ptr
, sals
.sals
[0].symtab
->filename
, -1);
1089 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1093 /* This implements the tcl command "gdb_get_function"
1095 * It finds the function containing the given line spec.
1098 * linespec - The line specification
1100 * The function that contains it, or "N/A" if it is not in a function.
1103 gdb_get_function_command (clientData
, interp
, objc
, objv
)
1104 ClientData clientData
;
1107 Tcl_Obj
*CONST objv
[];
1110 struct symtabs_and_lines sals
;
1111 char *args
, **canonical
;
1115 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1116 Tcl_GetStringFromObj (objv
[0], NULL
),
1117 " linespec\"", NULL
);
1121 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1122 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1123 if (sals
.nelts
== 1)
1125 resolve_sal_pc (&sals
.sals
[0]);
1126 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
1127 if (function
!= NULL
)
1129 Tcl_SetStringObj (result_ptr
->obj_ptr
, function
, -1);
1134 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1138 /* This implements the tcl command "gdb_find_file"
1140 * It searches the symbol tables to get the full pathname to a file.
1143 * filename: the file name to search for.
1145 * The full path to the file, or an empty string if the file is not
1150 gdb_find_file_command (clientData
, interp
, objc
, objv
)
1151 ClientData clientData
;
1154 Tcl_Obj
*CONST objv
[];
1156 char *filename
= NULL
;
1161 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
1165 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1167 filename
= st
->fullname
;
1169 if (filename
== NULL
)
1170 Tcl_SetStringObj (result_ptr
->obj_ptr
, "", 0);
1172 Tcl_SetStringObj (result_ptr
->obj_ptr
, filename
, -1);
1177 /* This implements the tcl command "gdb_listfiles"
1179 * This lists all the files in the current executible.
1181 * Note that this currently pulls in all sorts of filenames
1182 * that aren't really part of the executable. It would be
1183 * best if we could check each file to see if it actually
1184 * contains executable lines of code, but we can't do that
1188 * ?pathname? - If provided, only files which match pathname
1189 * (up to strlen(pathname)) are included. THIS DOES NOT
1190 * CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1191 * THE FULL PATHNAME!!!
1194 * A list of all matching files.
1197 gdb_listfiles (clientData
, interp
, objc
, objv
)
1198 ClientData clientData
;
1201 Tcl_Obj
*CONST objv
[];
1203 struct objfile
*objfile
;
1204 struct partial_symtab
*psymtab
;
1205 struct symtab
*symtab
;
1206 char *lastfile
, *pathname
=NULL
, **files
;
1208 int i
, numfiles
= 0, len
= 0;
1211 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1215 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1219 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1221 ALL_PSYMTABS (objfile
, psymtab
)
1223 if (numfiles
== files_size
)
1225 files_size
= files_size
* 2;
1226 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1228 if (psymtab
->filename
)
1230 if (!len
|| !strncmp(pathname
, psymtab
->filename
,len
)
1231 || !strcmp(psymtab
->filename
, basename(psymtab
->filename
)))
1233 files
[numfiles
++] = basename(psymtab
->filename
);
1238 ALL_SYMTABS (objfile
, symtab
)
1240 if (numfiles
== files_size
)
1242 files_size
= files_size
* 2;
1243 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1245 if (symtab
->filename
&& symtab
->linetable
&& symtab
->linetable
->nitems
)
1247 if (!len
|| !strncmp(pathname
, symtab
->filename
,len
)
1248 || !strcmp(symtab
->filename
, basename(symtab
->filename
)))
1250 files
[numfiles
++] = basename(symtab
->filename
);
1255 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1259 /* Discard the old result pointer, in case it has accumulated anything
1260 and set it to a new list object */
1262 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1264 for (i
= 0; i
< numfiles
; i
++)
1266 if (strcmp(files
[i
],lastfile
))
1267 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj(files
[i
], -1));
1268 lastfile
= files
[i
];
1276 comp_files (file1
, file2
)
1277 const void *file1
, *file2
;
1279 return strcmp(* (char **) file1
, * (char **) file2
);
1283 /* This implements the tcl command "gdb_search"
1287 * option - One of "functions", "variables" or "types"
1288 * regexp - The regular expression to look for.
1297 gdb_search (clientData
, interp
, objc
, objv
)
1298 ClientData clientData
;
1301 Tcl_Obj
*CONST objv
[];
1303 struct symbol_search
*ss
= NULL
;
1304 struct symbol_search
*p
;
1305 struct cleanup
*old_chain
= NULL
;
1306 Tcl_Obj
*CONST
*switch_objv
;
1307 int index
, switch_objc
, i
;
1308 namespace_enum space
= 0;
1310 int static_only
, nfiles
;
1311 Tcl_Obj
**file_list
;
1313 static char *search_options
[] = { "functions", "variables", "types", (char *) NULL
};
1314 static char *switches
[] = { "-files", "-static", (char *) NULL
};
1315 enum search_opts
{ SEARCH_FUNCTIONS
, SEARCH_VARIABLES
, SEARCH_TYPES
};
1316 enum switches_opts
{ SWITCH_FILES
, SWITCH_STATIC_ONLY
};
1320 Tcl_WrongNumArgs (interp
, 1, objv
, "option regexp ?arg ...?");
1321 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1325 if (Tcl_GetIndexFromObj (interp
, objv
[1], search_options
, "option", 0,
1328 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1332 /* Unfortunately, we cannot teach search_symbols to search on
1333 multiple regexps, so we have to do a two-tier search for
1334 any searches which choose to narrow the playing field. */
1335 switch ((enum search_opts
) index
)
1337 case SEARCH_FUNCTIONS
:
1338 space
= FUNCTIONS_NAMESPACE
; break;
1339 case SEARCH_VARIABLES
:
1340 space
= VARIABLES_NAMESPACE
; break;
1342 space
= TYPES_NAMESPACE
; break;
1345 regexp
= Tcl_GetStringFromObj (objv
[2], NULL
);
1346 /* Process any switches that refine the search */
1347 switch_objc
= objc
- 3;
1348 switch_objv
= objv
+ 3;
1352 files
= (char **) NULL
;
1353 while (switch_objc
> 0)
1355 if (Tcl_GetIndexFromObj (interp
, switch_objv
[0], switches
,
1356 "option", 0, &index
) != TCL_OK
)
1358 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1362 switch ((enum switches_opts
) index
)
1367 if (switch_objc
< 2)
1369 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList -static 1|0]");
1370 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1373 result
= Tcl_ListObjGetElements (interp
, switch_objv
[1], &nfiles
, &file_list
);
1374 if (result
!= TCL_OK
)
1377 files
= (char **) xmalloc (nfiles
* sizeof (char *));
1378 for (i
= 0; i
< nfiles
; i
++)
1379 files
[i
] = Tcl_GetStringFromObj (file_list
[i
], NULL
);
1384 case SWITCH_STATIC_ONLY
:
1385 if (switch_objc
< 2)
1387 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList] [-static 1|0]");
1388 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1391 if ( Tcl_GetBooleanFromObj (interp
, switch_objv
[1], &static_only
) !=
1393 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1403 search_symbols (regexp
, space
, nfiles
, files
, &ss
);
1405 old_chain
= make_cleanup ((make_cleanup_func
) free_search_symbols
, ss
);
1407 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1409 for (p
= ss
; p
!= NULL
; p
= p
->next
)
1413 if (static_only
&& p
->block
!= STATIC_BLOCK
)
1416 /* Strip off some C++ special symbols, like RTTI and global
1417 constructors/destructors. */
1418 if ((p
->symbol
!= NULL
&& !STREQN (SYMBOL_NAME (p
->symbol
), "__tf", 4)
1419 && !STREQN (SYMBOL_NAME (p
->symbol
), "_GLOBAL_", 8))
1420 || p
->msymbol
!= NULL
)
1422 elem
= Tcl_NewListObj (0, NULL
);
1424 if (p
->msymbol
== NULL
)
1425 Tcl_ListObjAppendElement (interp
, elem
,
1426 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->symbol
), -1));
1428 Tcl_ListObjAppendElement (interp
, elem
,
1429 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->msymbol
), -1));
1431 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, elem
);
1436 do_cleanups (old_chain
);
1441 /* This implements the tcl command gdb_listfuncs
1443 * It lists all the functions defined in a given file
1446 * file - the file to look in
1448 * A list of two element lists, the first element is
1449 * the symbol name, and the second is a boolean indicating
1450 * whether the symbol is demangled (1 for yes).
1454 gdb_listfuncs (clientData
, interp
, objc
, objv
)
1455 ClientData clientData
;
1458 Tcl_Obj
*CONST objv
[];
1460 struct symtab
*symtab
;
1461 struct blockvector
*bv
;
1465 Tcl_Obj
*funcVals
[2];
1469 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1472 symtab
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1475 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No such file", -1);
1479 if (mangled
== NULL
)
1481 mangled
= Tcl_NewBooleanObj(1);
1482 not_mangled
= Tcl_NewBooleanObj(0);
1483 Tcl_IncrRefCount(mangled
);
1484 Tcl_IncrRefCount(not_mangled
);
1487 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1489 bv
= BLOCKVECTOR (symtab
);
1490 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1492 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1493 /* Skip the sort if this block is always sorted. */
1494 if (!BLOCK_SHOULD_SORT (b
))
1495 sort_block_syms (b
);
1496 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1498 sym
= BLOCK_SYM (b
, j
);
1499 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1502 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1505 /* strip out "global constructors" and "global destructors" */
1506 /* because we aren't interested in them. */
1507 if (strncmp (name
, "global ", 7))
1509 funcVals
[0] = Tcl_NewStringObj(name
, -1);
1510 funcVals
[1] = mangled
;
1518 funcVals
[0] = Tcl_NewStringObj(SYMBOL_NAME(sym
), -1);
1519 funcVals
[1] = not_mangled
;
1521 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1522 Tcl_NewListObj (2, funcVals
));
1531 * This section contains all the commands that act on the registers:
1534 /* This is a sort of mapcar function for operations on registers */
1537 map_arg_registers (objc
, objv
, func
, argp
)
1539 Tcl_Obj
*CONST objv
[];
1540 void (*func
) PARAMS ((int regnum
, void *argp
));
1545 /* Note that the test for a valid register must include checking the
1546 REGISTER_NAME because NUM_REGS may be allocated for the union of
1547 the register sets within a family of related processors. In this
1548 case, some entries of REGISTER_NAME will change depending upon
1549 the particular processor being debugged. */
1551 if (objc
== 0) /* No args, just do all the regs */
1555 && REGISTER_NAME (regnum
) != NULL
1556 && *REGISTER_NAME (regnum
) != '\000';
1558 func (regnum
, argp
);
1563 /* Else, list of register #s, just do listed regs */
1564 for (; objc
> 0; objc
--, objv
++)
1566 if (Tcl_GetIntFromObj (NULL
, *objv
, ®num
) != TCL_OK
)
1568 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1573 && regnum
< NUM_REGS
1574 && REGISTER_NAME (regnum
) != NULL
1575 && *REGISTER_NAME (regnum
) != '\000')
1576 func (regnum
, argp
);
1579 Tcl_SetStringObj (result_ptr
->obj_ptr
, "bad register number", -1);
1587 /* This implements the TCL command `gdb_regnames', which returns a list of
1588 all of the register names. */
1591 gdb_regnames (clientData
, interp
, objc
, objv
)
1592 ClientData clientData
;
1595 Tcl_Obj
*CONST objv
[];
1600 return map_arg_registers (objc
, objv
, get_register_name
, NULL
);
1604 get_register_name (regnum
, argp
)
1606 void *argp
; /* Ignored */
1608 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1609 Tcl_NewStringObj (REGISTER_NAME (regnum
), -1));
1612 /* This implements the tcl command gdb_fetch_registers
1613 * Pass it a list of register names, and it will
1614 * return their values as a list.
1617 * format: The format string for printing the values
1618 * args: the registers to look for
1620 * A list of their values.
1624 gdb_fetch_registers (clientData
, interp
, objc
, objv
)
1625 ClientData clientData
;
1628 Tcl_Obj
*CONST objv
[];
1634 Tcl_SetStringObj (result_ptr
->obj_ptr
,
1635 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
1639 format
= *(Tcl_GetStringFromObj(objv
[0], NULL
));
1643 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Output the results as a list */
1644 result
= map_arg_registers (objc
, objv
, get_register
, (void *) format
);
1645 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
1651 get_register (regnum
, fp
)
1655 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1656 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
1657 int format
= (int)fp
;
1663 /* read_relative_register_raw_bytes returns a virtual frame pointer
1664 (FRAME_FP (selected_frame)) if regnum == FP_REGNUM instead
1665 of the real contents of the register. To get around this,
1666 use get_saved_register instead. */
1667 get_saved_register (raw_buffer
, &optim
, (CORE_ADDR
*) NULL
, selected_frame
,
1668 regnum
, (enum lval_type
*) NULL
);
1671 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1672 Tcl_NewStringObj ("Optimized out", -1));
1676 /* Convert raw data to virtual format if necessary. */
1678 if (REGISTER_CONVERTIBLE (regnum
))
1680 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
1681 raw_buffer
, virtual_buffer
);
1684 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1689 printf_filtered ("0x");
1690 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1692 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1693 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1694 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
1698 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0, 0,
1699 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1703 /* This implements the tcl command get_pc_reg
1704 * It returns the value of the PC register
1709 * The value of the pc register.
1713 get_pc_register (clientData
, interp
, objc
, objv
)
1714 ClientData clientData
;
1717 Tcl_Obj
*CONST objv
[];
1721 sprintf (buff
, "0x%llx",(long long) read_register (PC_REGNUM
));
1722 Tcl_SetStringObj(result_ptr
->obj_ptr
, buff
, -1);
1726 /* This implements the tcl command "gdb_changed_register_list"
1727 * It takes a list of registers, and returns a list of
1728 * the registers on that list that have changed since the last
1729 * time the proc was called.
1732 * A list of registers.
1734 * A list of changed registers.
1738 gdb_changed_register_list (clientData
, interp
, objc
, objv
)
1739 ClientData clientData
;
1742 Tcl_Obj
*CONST objv
[];
1747 return map_arg_registers (objc
, objv
, register_changed_p
, NULL
);
1751 register_changed_p (regnum
, argp
)
1753 void *argp
; /* Ignored */
1755 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1757 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1760 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1761 REGISTER_RAW_SIZE (regnum
)) == 0)
1764 /* Found a changed register. Save new value and return its number. */
1766 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1767 REGISTER_RAW_SIZE (regnum
));
1769 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(regnum
));
1773 * This section contains the commands that deal with tracepoints:
1776 /* return a list of all tracepoint numbers in interpreter */
1778 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
1779 ClientData clientData
;
1782 Tcl_Obj
*CONST objv
[];
1784 struct tracepoint
*tp
;
1786 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1788 ALL_TRACEPOINTS (tp
)
1789 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->number
));
1794 /* returns -1 if not found, tracepoint # if found */
1796 tracepoint_exists (char * args
)
1798 struct tracepoint
*tp
;
1800 struct symtabs_and_lines sals
;
1804 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1805 if (sals
.nelts
== 1)
1807 resolve_sal_pc (&sals
.sals
[0]);
1808 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
1809 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
1812 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
1813 strcat (file
, sals
.sals
[0].symtab
->filename
);
1815 ALL_TRACEPOINTS (tp
)
1817 if (tp
->address
== sals
.sals
[0].pc
)
1818 result
= tp
->number
;
1820 /* Why is this here? This messes up assembly traces */
1821 else if (tp
->source_file
!= NULL
1822 && strcmp (tp
->source_file
, file
) == 0
1823 && sals
.sals
[0].line
== tp
->line_number
)
1824 result
= tp
->number
;
1835 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
1836 ClientData clientData
;
1839 Tcl_Obj
*CONST objv
[];
1845 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1846 Tcl_GetStringFromObj (objv
[0], NULL
),
1847 " function:line|function|line|*addr\"", NULL
);
1851 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1853 Tcl_SetIntObj (result_ptr
->obj_ptr
, tracepoint_exists (args
));
1858 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
1859 ClientData clientData
;
1862 Tcl_Obj
*CONST objv
[];
1864 struct symtab_and_line sal
;
1866 struct tracepoint
*tp
;
1867 struct action_line
*al
;
1868 Tcl_Obj
*action_list
;
1869 char *filename
, *funcname
, *fname
;
1874 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1878 if (Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
) != TCL_OK
)
1880 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1884 ALL_TRACEPOINTS (tp
)
1885 if (tp
->number
== tpnum
)
1891 sprintf (buff
, "Tracepoint #%d does not exist", tpnum
);
1892 Tcl_SetStringObj (result_ptr
->obj_ptr
, buff
, -1);
1896 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1897 sal
= find_pc_line (tp
->address
, 0);
1898 filename
= symtab_to_filename (sal
.symtab
);
1899 if (filename
== NULL
)
1901 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1902 Tcl_NewStringObj (filename
, -1));
1904 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
1905 fname
= cplus_demangle (funcname
, 0);
1908 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj
1913 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj
1916 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (sal
.line
));
1917 sprintf (tmp
, "0x%lx", tp
->address
);
1918 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (tmp
, -1));
1919 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->enabled
));
1920 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->pass_count
));
1921 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->step_count
));
1922 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->thread
));
1923 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->hit_count
));
1925 /* Append a list of actions */
1926 action_list
= Tcl_NewObj ();
1927 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
1929 Tcl_ListObjAppendElement (interp
, action_list
,
1930 Tcl_NewStringObj (al
->action
, -1));
1932 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, action_list
);
1939 gdb_trace_status (clientData
, interp
, objc
, objv
)
1940 ClientData clientData
;
1943 Tcl_Obj
*CONST objv
[];
1947 if (trace_running_p
)
1950 Tcl_SetIntObj (result_ptr
->obj_ptr
, result
);
1957 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
1958 ClientData clientData
;
1961 Tcl_Obj
*CONST objv
[];
1965 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1966 Tcl_GetStringFromObj (objv
[0], NULL
),
1967 " linespec\"", NULL
);
1971 Tcl_SetIntObj (result_ptr
->obj_ptr
, get_traceframe_number ());
1976 /* This implements the tcl command gdb_actions
1977 * It sets actions for a given tracepoint.
1980 * number: the tracepoint in question
1981 * actions: the actions to add to this tracepoint
1987 gdb_actions_command (clientData
, interp
, objc
, objv
)
1988 ClientData clientData
;
1991 Tcl_Obj
*CONST objv
[];
1993 struct tracepoint
*tp
;
1995 int nactions
, i
, len
;
1996 char *number
, *args
, *action
;
1998 struct action_line
*next
= NULL
, *temp
;
1999 enum actionline_type linetype
;
2003 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # args: should be: \"",
2004 Tcl_GetStringFromObj (objv
[0], NULL
),
2005 " number actions\"", NULL
);
2009 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
2010 tp
= get_tracepoint_by_number (&args
);
2013 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "Tracepoint \"", number
, "\" does not exist", NULL
);
2017 /* Free any existing actions */
2018 if (tp
->actions
!= NULL
)
2023 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
2025 /* Add the actions to the tracepoint */
2026 for (i
= 0; i
< nactions
; i
++)
2028 temp
= xmalloc (sizeof (struct action_line
));
2030 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
2031 temp
->action
= savestring (action
, len
);
2033 linetype
= validate_actionline (&(temp
->action
), tp
);
2035 if (linetype
== BADLINE
)
2057 * This section has commands that handle source disassembly.
2060 /* This implements the tcl command gdb_disassemble
2063 * source_with_assm - must be "source" or "nosource"
2064 * low_address - the address from which to start disassembly
2065 * ?hi_address? - the address to which to disassemble, defaults
2066 * to the end of the function containing low_address.
2068 * The disassembled code is passed to fputs_unfiltered, so it
2069 * either goes to the console if result_ptr->obj_ptr is NULL or to
2074 gdb_disassemble (clientData
, interp
, objc
, objv
)
2075 ClientData clientData
;
2078 Tcl_Obj
*CONST objv
[];
2080 CORE_ADDR pc
, low
, high
;
2081 int mixed_source_and_assembly
;
2082 static disassemble_info di
;
2083 static int di_initialized
;
2086 if (objc
!= 3 && objc
!= 4)
2087 error ("wrong # args");
2089 if (! di_initialized
)
2091 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
2092 (fprintf_ftype
) fprintf_unfiltered
);
2093 di
.flavour
= bfd_target_unknown_flavour
;
2094 di
.memory_error_func
= dis_asm_memory_error
;
2095 di
.print_address_func
= dis_asm_print_address
;
2099 di
.mach
= TARGET_PRINT_INSN_INFO
->mach
;
2100 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
2101 di
.endian
= BFD_ENDIAN_BIG
;
2103 di
.endian
= BFD_ENDIAN_LITTLE
;
2105 arg_ptr
= Tcl_GetStringFromObj (objv
[1], NULL
);
2106 if (*arg_ptr
== 's' && strcmp (arg_ptr
, "source") == 0)
2107 mixed_source_and_assembly
= 1;
2108 else if (*arg_ptr
== 'n' && strcmp (arg_ptr
, "nosource") == 0)
2109 mixed_source_and_assembly
= 0;
2111 error ("First arg must be 'source' or 'nosource'");
2113 low
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[2], NULL
));
2117 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
2118 error ("No function contains specified address");
2121 high
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[3], NULL
));
2123 /* If disassemble_from_exec == -1, then we use the following heuristic to
2124 determine whether or not to do disassembly from target memory or from the
2127 If we're debugging a local process, read target memory, instead of the
2128 exec file. This makes disassembly of functions in shared libs work
2131 Else, we're debugging a remote process, and should disassemble from the
2132 exec file for speed. However, this is no good if the target modifies its
2133 code (for relocation, or whatever).
2136 if (disassemble_from_exec
== -1)
2138 if (strcmp (target_shortname
, "child") == 0
2139 || strcmp (target_shortname
, "procfs") == 0
2140 || strcmp (target_shortname
, "vxprocess") == 0)
2141 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
2143 disassemble_from_exec
= 1; /* It's remote, read the exec file */
2146 if (disassemble_from_exec
)
2147 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
2149 di
.read_memory_func
= dis_asm_read_memory
;
2151 /* If just doing straight assembly, all we need to do is disassemble
2152 everything between low and high. If doing mixed source/assembly, we've
2153 got a totally different path to follow. */
2155 if (mixed_source_and_assembly
)
2156 { /* Come here for mixed source/assembly */
2157 /* The idea here is to present a source-O-centric view of a function to
2158 the user. This means that things are presented in source order, with
2159 (possibly) out of order assembly immediately following. */
2160 struct symtab
*symtab
;
2161 struct linetable_entry
*le
;
2164 struct my_line_entry
*mle
;
2165 struct symtab_and_line sal
;
2170 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
2172 if (!symtab
|| !symtab
->linetable
)
2175 /* First, convert the linetable to a bunch of my_line_entry's. */
2177 le
= symtab
->linetable
->item
;
2178 nlines
= symtab
->linetable
->nitems
;
2183 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
2187 /* Copy linetable entries for this function into our data structure, creating
2188 end_pc's and setting out_of_order as appropriate. */
2190 /* First, skip all the preceding functions. */
2192 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
2194 /* Now, copy all entries before the end of this function. */
2197 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
2199 if (le
[i
].line
== le
[i
+ 1].line
2200 && le
[i
].pc
== le
[i
+ 1].pc
)
2201 continue; /* Ignore duplicates */
2203 mle
[newlines
].line
= le
[i
].line
;
2204 if (le
[i
].line
> le
[i
+ 1].line
)
2206 mle
[newlines
].start_pc
= le
[i
].pc
;
2207 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
2211 /* If we're on the last line, and it's part of the function, then we need to
2212 get the end pc in a special way. */
2217 mle
[newlines
].line
= le
[i
].line
;
2218 mle
[newlines
].start_pc
= le
[i
].pc
;
2219 sal
= find_pc_line (le
[i
].pc
, 0);
2220 mle
[newlines
].end_pc
= sal
.end
;
2224 /* Now, sort mle by line #s (and, then by addresses within lines). */
2227 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
2229 /* Now, for each line entry, emit the specified lines (unless they have been
2230 emitted before), followed by the assembly code for that line. */
2232 next_line
= 0; /* Force out first line */
2233 for (i
= 0; i
< newlines
; i
++)
2235 /* Print out everything from next_line to the current line. */
2237 if (mle
[i
].line
>= next_line
)
2240 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
2242 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
2244 next_line
= mle
[i
].line
+ 1;
2247 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
2250 fputs_unfiltered (" ", gdb_stdout
);
2251 print_address (pc
, gdb_stdout
);
2252 fputs_unfiltered (":\t ", gdb_stdout
);
2253 pc
+= (*tm_print_insn
) (pc
, &di
);
2254 fputs_unfiltered ("\n", gdb_stdout
);
2261 for (pc
= low
; pc
< high
; )
2264 fputs_unfiltered (" ", gdb_stdout
);
2265 print_address (pc
, gdb_stdout
);
2266 fputs_unfiltered (":\t ", gdb_stdout
);
2267 pc
+= (*tm_print_insn
) (pc
, &di
);
2268 fputs_unfiltered ("\n", gdb_stdout
);
2272 gdb_flush (gdb_stdout
);
2277 /* This is the memory_read_func for gdb_disassemble when we are
2278 disassembling from the exec file. */
2281 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
2285 disassemble_info
*info
;
2287 extern struct target_ops exec_ops
;
2291 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
2302 /* This will be passed to qsort to sort the results of the disassembly */
2305 compare_lines (mle1p
, mle2p
)
2309 struct my_line_entry
*mle1
, *mle2
;
2312 mle1
= (struct my_line_entry
*) mle1p
;
2313 mle2
= (struct my_line_entry
*) mle2p
;
2315 val
= mle1
->line
- mle2
->line
;
2320 return mle1
->start_pc
- mle2
->start_pc
;
2323 /* This implements the TCL command `gdb_loc',
2326 * ?symbol? The symbol or address to locate - defaults to pc
2328 * a list consisting of the following:
2329 * basename, function name, filename, line number, address, current pc
2333 gdb_loc (clientData
, interp
, objc
, objv
)
2334 ClientData clientData
;
2337 Tcl_Obj
*CONST objv
[];
2340 struct symtab_and_line sal
;
2341 char *funcname
, *fname
;
2344 if (!have_full_symbols () && !have_partial_symbols ())
2346 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No symbol table is loaded", -1);
2352 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
2354 /* Note - this next line is not correct on all architectures. */
2355 /* For a graphical debugger we really want to highlight the */
2356 /* assembly line that called the next function on the stack. */
2357 /* Many architectures have the next instruction saved as the */
2358 /* pc on the stack, so what happens is the next instruction is hughlighted. */
2360 pc
= selected_frame
->pc
;
2361 sal
= find_pc_line (selected_frame
->pc
,
2362 selected_frame
->next
!= NULL
2363 && !selected_frame
->next
->signal_handler_caller
2364 && !frame_in_dummy (selected_frame
->next
));
2369 sal
= find_pc_line (stop_pc
, 0);
2374 struct symtabs_and_lines sals
;
2377 sals
= decode_line_spec (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
2383 if (sals
.nelts
!= 1)
2385 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Ambiguous line spec", -1);
2392 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
2397 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2398 Tcl_NewStringObj (sal
.symtab
->filename
, -1));
2400 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewStringObj ("", 0));
2402 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
2403 fname
= cplus_demangle (funcname
, 0);
2406 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2407 Tcl_NewStringObj (fname
, -1));
2411 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2412 Tcl_NewStringObj (funcname
, -1));
2414 filename
= symtab_to_filename (sal
.symtab
);
2415 if (filename
== NULL
)
2418 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2419 Tcl_NewStringObj (filename
, -1));
2420 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(sal
.line
)); /* line number */
2421 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
2422 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
2426 /* This implements the Tcl command 'gdb_get_mem', which
2427 * dumps a block of memory
2429 * gdb_get_mem addr form size num aschar
2431 * addr: address of data to dump
2432 * form: a char indicating format
2433 * size: size of each element; 1,2,4, or 8 bytes
2434 * num: the number of bytes to read
2435 * acshar: an optional ascii character to use in ASCII dump
2438 * a list of elements followed by an optional ASCII dump
2442 gdb_get_mem (clientData
, interp
, objc
, objv
)
2443 ClientData clientData
;
2446 Tcl_Obj
*CONST objv
[];
2448 int size
, asize
, i
, j
, bc
;
2450 int nbytes
, rnum
, bpr
;
2452 char format
, c
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
2453 struct type
*val_type
;
2455 if (objc
< 6 || objc
> 7)
2457 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2458 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2462 if (Tcl_GetIntFromObj (interp
, objv
[3], &size
) != TCL_OK
)
2464 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2469 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid size, must be > 0", -1);
2473 if (Tcl_GetIntFromObj (interp
, objv
[4], &nbytes
) != TCL_OK
)
2475 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2480 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid number of bytes, must be > 0",
2485 if (Tcl_GetIntFromObj (interp
, objv
[5], &bpr
) != TCL_OK
)
2487 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2492 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid bytes per row, must be > 0", -1);
2496 if (Tcl_GetLongFromObj (interp
, objv
[1], &tmp
) != TCL_OK
)
2499 addr
= (CORE_ADDR
) tmp
;
2501 format
= *(Tcl_GetStringFromObj (objv
[2], NULL
));
2502 mbuf
= (char *)malloc (nbytes
+32);
2505 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Out of memory.", -1);
2509 memset (mbuf
, 0, nbytes
+32);
2512 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
2515 aschar
= *(Tcl_GetStringFromObj(objv
[6], NULL
));
2521 val_type
= builtin_type_char
;
2525 val_type
= builtin_type_short
;
2529 val_type
= builtin_type_int
;
2533 val_type
= builtin_type_long_long
;
2537 val_type
= builtin_type_char
;
2541 bc
= 0; /* count of bytes in a row */
2542 buff
[0] = '"'; /* buffer for ascii dump */
2543 bptr
= &buff
[1]; /* pointer for ascii dump */
2545 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Build up the result as a list... */
2547 for (i
=0; i
< nbytes
; i
+= size
)
2551 fputs_unfiltered ("N/A ", gdb_stdout
);
2553 for ( j
= 0; j
< size
; j
++)
2558 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
2562 for ( j
= 0; j
< size
; j
++)
2565 if (c
< 32 || c
> 126)
2577 if (aschar
&& (bc
>= bpr
))
2579 /* end of row. print it and reset variables */
2584 fputs_unfiltered (buff
, gdb_stdout
);
2589 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
2597 /* This implements the tcl command "gdb_loadfile"
2598 * It loads a c source file into a text widget.
2601 * widget: the name of the text widget to fill
2602 * filename: the name of the file to load
2603 * linenumbers: A boolean indicating whether or not to display line numbers.
2608 /* In this routine, we will build up a "line table", i.e. a
2609 * table of bits showing which lines in the source file are executible.
2610 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2612 * Its size limits the maximum number of lines
2613 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2614 * the file is loaded, so it is OK to make this very large.
2615 * Additional memory will be allocated if needed. */
2616 #define LTABLE_SIZE 20000
2618 gdb_loadfile (clientData
, interp
, objc
, objv
)
2619 ClientData clientData
;
2622 Tcl_Obj
*CONST objv
[];
2624 char *file
, *widget
;
2625 int linenumbers
, ln
, lnum
, ltable_size
;
2628 struct symtab
*symtab
;
2629 struct linetable_entry
*le
;
2632 Tcl_DString text_cmd_1
, text_cmd_2
, *cur_cmd
;
2633 char line
[1024], line_num_buf
[16];
2634 int prefix_len_1
, prefix_len_2
, cur_prefix_len
, widget_len
;
2639 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
2643 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
2644 if ( Tk_NameToWindow (interp
, widget
, Tk_MainWindow (interp
)) == NULL
)
2649 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
2650 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
2652 symtab
= full_lookup_symtab (file
);
2655 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "File not found in symtab", -1);
2660 file
= symtab_to_filename ( symtab
);
2661 if ((fp
= fopen ( file
, "r" )) == NULL
)
2663 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Can't open file for reading", -1);
2667 if (stat (file
, &st
) < 0)
2669 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
2674 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
2675 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
2677 mtime
= bfd_get_mtime(exec_bfd
);
2679 if (mtime
&& mtime
< st
.st_mtime
)
2680 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2683 /* Source linenumbers don't appear to be in order, and a sort is */
2684 /* too slow so the fastest solution is just to allocate a huge */
2685 /* array and set the array entry for each linenumber */
2687 ltable_size
= LTABLE_SIZE
;
2688 ltable
= (char *)malloc (LTABLE_SIZE
);
2691 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2696 memset (ltable
, 0, LTABLE_SIZE
);
2698 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
2700 le
= symtab
->linetable
->item
;
2701 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
2703 lnum
= le
->line
>> 3;
2704 if (lnum
>= ltable_size
)
2707 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
2708 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
2710 if (new_ltable
== NULL
)
2712 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2717 ltable
= new_ltable
;
2719 ltable
[lnum
] |= 1 << (le
->line
% 8);
2723 Tcl_DStringInit(&text_cmd_1
);
2724 Tcl_DStringInit(&text_cmd_2
);
2728 widget_len
= strlen (widget
);
2731 Tcl_DStringAppend (&text_cmd_1
, widget
, widget_len
);
2732 Tcl_DStringAppend (&text_cmd_2
, widget
, widget_len
);
2736 Tcl_DStringAppend (&text_cmd_1
, " insert end {-\t", -1);
2737 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2739 Tcl_DStringAppend (&text_cmd_2
, " insert end { \t", -1);
2740 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2742 while (fgets (line
+ 1, 980, fp
))
2744 sprintf (line_num_buf
, "%d", ln
);
2745 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2747 cur_cmd
= &text_cmd_1
;
2748 cur_prefix_len
= prefix_len_1
;
2749 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2750 Tcl_DStringAppend (cur_cmd
, "} break_rgn_tag", 15);
2754 cur_cmd
= &text_cmd_2
;
2755 cur_prefix_len
= prefix_len_2
;
2756 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2757 Tcl_DStringAppend (cur_cmd
, "} \"\"", 4);
2760 Tcl_DStringAppendElement (cur_cmd
, line
);
2761 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2763 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2764 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2770 Tcl_DStringAppend (&text_cmd_1
, " insert end {- } break_rgn_tag", -1);
2771 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2772 Tcl_DStringAppend (&text_cmd_2
, " insert end { } \"\"", -1);
2773 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2775 while (fgets (line
+ 1, 980, fp
))
2777 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2779 cur_cmd
= &text_cmd_1
;
2780 cur_prefix_len
= prefix_len_1
;
2784 cur_cmd
= &text_cmd_2
;
2785 cur_prefix_len
= prefix_len_2
;
2788 Tcl_DStringAppendElement (cur_cmd
, line
);
2789 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2791 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2792 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2798 Tcl_DStringFree (&text_cmd_1
);
2799 Tcl_DStringFree (&text_cmd_2
);
2806 * This section contains commands for manipulation of breakpoints.
2810 /* set a breakpoint by source file and line number */
2811 /* flags are as follows: */
2812 /* least significant 2 bits are disposition, rest is */
2813 /* type (normally 0).
2816 bp_breakpoint, Normal breakpoint
2817 bp_hardware_breakpoint, Hardware assisted breakpoint
2820 Disposition of breakpoint. Ie: what to do after hitting it.
2823 del_at_next_stop, Delete at next stop, whether hit or not
2825 donttouch Leave it alone
2829 /* This implements the tcl command "gdb_set_bp"
2830 * It sets breakpoints, and runs the Tcl command
2831 * gdbtk_tcl_breakpoint create
2832 * to register the new breakpoint with the GUI.
2835 * filename: the file in which to set the breakpoint
2836 * line: the line number for the breakpoint
2837 * type: the type of the breakpoint
2838 * thread: optional thread number
2840 * The return value of the call to gdbtk_tcl_breakpoint.
2844 gdb_set_bp (clientData
, interp
, objc
, objv
)
2845 ClientData clientData
;
2848 Tcl_Obj
*CONST objv
[];
2851 struct symtab_and_line sal
;
2852 int line
, flags
, ret
, thread
= -1;
2853 struct breakpoint
*b
;
2857 if (objc
!= 4 && objc
!= 5)
2859 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type [thread]");
2863 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
2864 if (sal
.symtab
== NULL
)
2867 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
2869 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2873 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
2875 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2881 if (Tcl_GetIntFromObj( interp
, objv
[4], &thread
) == TCL_ERROR
)
2883 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2889 if (!find_line_pc (sal
.symtab
, sal
.line
, &sal
.pc
))
2892 sal
.section
= find_pc_overlay (sal
.pc
);
2893 b
= set_raw_breakpoint (sal
);
2894 set_breakpoint_count (breakpoint_count
+ 1);
2895 b
->number
= breakpoint_count
;
2896 b
->type
= flags
>> 2;
2897 b
->disposition
= flags
& 3;
2900 /* FIXME: this won't work for duplicate basenames! */
2901 sprintf (buf
, "%s:%d", basename (Tcl_GetStringFromObj ( objv
[1], NULL
)), line
);
2902 b
->addr_string
= strsave (buf
);
2904 /* now send notification command back to GUI */
2906 Tcl_DStringInit (&cmd
);
2908 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2909 sprintf (buf
, "%d", b
->number
);
2910 Tcl_DStringAppendElement(&cmd
, buf
);
2911 sprintf (buf
, "0x%lx", (long)sal
.pc
);
2912 Tcl_DStringAppendElement (&cmd
, buf
);
2913 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[2], NULL
));
2914 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[1], NULL
));
2915 Tcl_DStringAppendElement (&cmd
, bpdisp
[b
->disposition
]);
2916 sprintf (buf
, "%d", b
->enable
);
2917 Tcl_DStringAppendElement (&cmd
, buf
);
2918 sprintf (buf
, "%d", b
->thread
);
2919 Tcl_DStringAppendElement (&cmd
, buf
);
2922 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2923 Tcl_DStringFree (&cmd
);
2927 /* This implements the tcl command "gdb_set_bp_addr"
2928 * It sets breakpoints, and runs the Tcl command
2929 * gdbtk_tcl_breakpoint create
2930 * to register the new breakpoint with the GUI.
2933 * addr: the address at which to set the breakpoint
2934 * type: the type of the breakpoint
2935 * thread: optional thread number
2937 * The return value of the call to gdbtk_tcl_breakpoint.
2941 gdb_set_bp_addr (clientData
, interp
, objc
, objv
)
2942 ClientData clientData
;
2945 Tcl_Obj
*CONST objv
[];
2948 struct symtab_and_line sal
;
2949 int line
, flags
, ret
, thread
= -1;
2951 struct breakpoint
*b
;
2952 char *filename
, buf
[64];
2955 if (objc
!= 4 && objc
!= 3)
2957 Tcl_WrongNumArgs(interp
, 1, objv
, "addr type ?thread?");
2961 if (Tcl_GetLongFromObj( interp
, objv
[1], &addr
) == TCL_ERROR
)
2963 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2967 if (Tcl_GetIntFromObj( interp
, objv
[2], &flags
) == TCL_ERROR
)
2969 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2975 if (Tcl_GetIntFromObj( interp
, objv
[3], &thread
) == TCL_ERROR
)
2977 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2982 sal
= find_pc_line (addr
, 0);
2984 b
= set_raw_breakpoint (sal
);
2985 set_breakpoint_count (breakpoint_count
+ 1);
2986 b
->number
= breakpoint_count
;
2987 b
->type
= flags
>> 2;
2988 b
->disposition
= flags
& 3;
2991 sprintf (buf
, "*(0x%lx)",addr
);
2992 b
->addr_string
= strsave (buf
);
2994 /* now send notification command back to GUI */
2996 Tcl_DStringInit (&cmd
);
2998 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2999 sprintf (buf
, "%d", b
->number
);
3000 Tcl_DStringAppendElement(&cmd
, buf
);
3001 sprintf (buf
, "0x%lx", addr
);
3002 Tcl_DStringAppendElement (&cmd
, buf
);
3003 sprintf (buf
, "%d", b
->line_number
);
3004 Tcl_DStringAppendElement (&cmd
, buf
);
3006 filename
= symtab_to_filename (sal
.symtab
);
3007 if (filename
== NULL
)
3009 Tcl_DStringAppendElement (&cmd
, filename
);
3010 Tcl_DStringAppendElement (&cmd
, bpdisp
[b
->disposition
]);
3011 sprintf (buf
, "%d", b
->enable
);
3012 Tcl_DStringAppendElement (&cmd
, buf
);
3013 sprintf (buf
, "%d", b
->thread
);
3014 Tcl_DStringAppendElement (&cmd
, buf
);
3016 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
3017 Tcl_DStringFree (&cmd
);
3021 /* This implements the tcl command "gdb_find_bp_at_line"
3024 * filename: the file in which to find the breakpoint
3025 * line: the line number for the breakpoint
3027 * It returns a list of breakpoint numbers
3031 gdb_find_bp_at_line(clientData
, interp
, objc
, objv
)
3032 ClientData clientData
;
3035 Tcl_Obj
*CONST objv
[];
3040 struct breakpoint
*b
;
3041 extern struct breakpoint
*breakpoint_chain
;
3045 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line");
3049 s
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
3053 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
3055 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3059 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3060 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3061 if (b
->line_number
== line
&& !strcmp(b
->source_file
, s
->filename
))
3062 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3063 Tcl_NewIntObj (b
->number
));
3069 /* This implements the tcl command "gdb_find_bp_at_addr"
3074 * It returns a list of breakpoint numbers
3078 gdb_find_bp_at_addr(clientData
, interp
, objc
, objv
)
3079 ClientData clientData
;
3082 Tcl_Obj
*CONST objv
[];
3086 struct breakpoint
*b
;
3087 extern struct breakpoint
*breakpoint_chain
;
3091 Tcl_WrongNumArgs(interp
, 1, objv
, "address");
3095 if (Tcl_GetLongFromObj( interp
, objv
[1], &addr
) == TCL_ERROR
)
3097 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3101 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3102 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3103 if (b
->address
== (CORE_ADDR
)addr
)
3104 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3105 Tcl_NewIntObj (b
->number
));
3110 /* This implements the tcl command gdb_get_breakpoint_info
3116 * A list with {file, function, line_number, address, type, enabled?,
3117 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
3121 gdb_get_breakpoint_info (clientData
, interp
, objc
, objv
)
3122 ClientData clientData
;
3125 Tcl_Obj
*CONST objv
[];
3127 struct symtab_and_line sal
;
3128 struct command_line
*cmd
;
3130 struct breakpoint
*b
;
3131 extern struct breakpoint
*breakpoint_chain
;
3132 char *funcname
, *fname
, *filename
;
3137 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong number of args, should be \"breakpoint\"", -1);
3141 if ( Tcl_GetIntFromObj(NULL
, objv
[1], &bpnum
) != TCL_OK
)
3143 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3147 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3148 if (b
->number
== bpnum
)
3151 if (!b
|| b
->type
!= bp_breakpoint
)
3154 sprintf(err_buf
, "Breakpoint #%d does not exist.", bpnum
);
3155 Tcl_SetStringObj (result_ptr
->obj_ptr
, err_buf
, -1);
3159 sal
= find_pc_line (b
->address
, 0);
3161 filename
= symtab_to_filename (sal
.symtab
);
3162 if (filename
== NULL
)
3165 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3166 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3167 Tcl_NewStringObj (filename
, -1));
3169 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
3170 fname
= cplus_demangle (funcname
, 0);
3173 new_obj
= Tcl_NewStringObj (fname
, -1);
3177 new_obj
= Tcl_NewStringObj (funcname
, -1);
3179 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
3181 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->line_number
));
3182 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%lx", b
->address
);
3183 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3184 Tcl_NewStringObj (bptypes
[b
->type
], -1));
3185 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewBooleanObj(b
->enable
== enabled
));
3186 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3187 Tcl_NewStringObj (bpdisp
[b
->disposition
], -1));
3188 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->ignore_count
));
3190 new_obj
= Tcl_NewObj();
3191 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
3192 Tcl_ListObjAppendElement (NULL
, new_obj
,
3193 Tcl_NewStringObj (cmd
->line
, -1));
3194 Tcl_ListObjAppendElement(NULL
, result_ptr
->obj_ptr
, new_obj
);
3196 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3197 Tcl_NewStringObj (b
->cond_string
, -1));
3199 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->thread
));
3200 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->hit_count
));
3206 /* This implements the tcl command gdb_get_breakpoint_list
3207 * It builds up a list of the current breakpoints.
3212 * A list of breakpoint numbers.
3216 gdb_get_breakpoint_list (clientData
, interp
, objc
, objv
)
3217 ClientData clientData
;
3220 Tcl_Obj
*CONST objv
[];
3222 struct breakpoint
*b
;
3223 extern struct breakpoint
*breakpoint_chain
;
3227 error ("wrong number of args, none are allowed");
3229 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3230 if (b
->type
== bp_breakpoint
)
3232 new_obj
= Tcl_NewIntObj (b
->number
);
3233 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
3239 /* The functions in this section deal with stacks and backtraces. */
3241 /* This implements the tcl command gdb_stack.
3242 * It builds up a list of stack frames.
3245 * start - starting stack frame
3246 * count - number of frames to inspect
3248 * A list of function names
3252 gdb_stack (clientData
, interp
, objc
, objv
) ClientData clientData
;
3255 Tcl_Obj
*CONST objv
[];
3261 Tcl_WrongNumArgs (interp
, 1, objv
, "start count");
3262 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3266 if (Tcl_GetIntFromObj (NULL
, objv
[1], &start
))
3268 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3271 if (Tcl_GetIntFromObj (NULL
, objv
[2], &count
))
3273 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3277 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
3279 if (target_has_stack
)
3281 struct frame_info
*top
;
3282 struct frame_info
*fi
;
3284 /* Find the outermost frame */
3285 fi
= get_current_frame ();
3289 fi
= get_prev_frame (fi
);
3292 /* top now points to the top (outermost frame) of the
3293 stack, so point it to the requested start */
3295 top
= find_relative_frame (top
, &start
);
3297 /* If start != 0, then we have asked to start outputting
3298 frames beyond the innermost stack frame */
3302 while (fi
&& count
--)
3304 get_frame_name (interp
, result_ptr
->obj_ptr
, fi
);
3305 fi
= get_next_frame (fi
);
3313 /* A helper function for get_stack which adds information about
3314 * the stack frame FI to the caller's LIST.
3316 * This is stolen from print_frame_info in stack.c.
3319 get_frame_name (interp
, list
, fi
)
3322 struct frame_info
*fi
;
3324 struct symtab_and_line sal
;
3325 struct symbol
*func
= NULL
;
3326 register char *funname
= 0;
3327 enum language funlang
= language_unknown
;
3330 if (frame_in_dummy (fi
))
3332 objv
[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
3333 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3336 if (fi
->signal_handler_caller
)
3338 objv
[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
3339 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3344 find_pc_line (fi
->pc
,
3346 && !fi
->next
->signal_handler_caller
3347 && !frame_in_dummy (fi
->next
));
3349 func
= find_pc_function (fi
->pc
);
3352 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3354 && (SYMBOL_VALUE_ADDRESS (msymbol
)
3355 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
3358 funname
= SYMBOL_NAME (msymbol
);
3359 funlang
= SYMBOL_LANGUAGE (msymbol
);
3363 funname
= SYMBOL_NAME (func
);
3364 funlang
= SYMBOL_LANGUAGE (func
);
3369 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3370 if (msymbol
!= NULL
)
3372 funname
= SYMBOL_NAME (msymbol
);
3373 funlang
= SYMBOL_LANGUAGE (msymbol
);
3381 if (funlang
== language_cplus
)
3382 name
= cplus_demangle (funname
, 0);
3386 objv
[0] = Tcl_NewStringObj (name
, -1);
3387 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3392 /* we have no convenient way to deal with this yet... */
3393 if (fi
->pc
!= sal
.pc
|| !sal
.symtab
)
3395 print_address_numeric (fi
->pc
, 1, gdb_stdout
);
3396 printf_filtered (" in ");
3398 fprintf_symbol_filtered (gdb_stdout
, funname
? funname
: "??", funlang
,
3401 objv
[0] = Tcl_NewStringObj (funname
!= NULL
? funname
: "??", -1);
3402 #ifdef PC_LOAD_SEGMENT
3403 /* If we couldn't print out function name but if can figure out what
3404 load segment this pc value is from, at least print out some info
3405 about its load segment. */
3408 Tcl_AppendStringsToObj (objv
[0], " from ", PC_LOAD_SEGMENT (fi
->pc
),
3415 char *lib
= PC_SOLIB (fi
->pc
);
3418 Tcl_AppendStringsToObj (objv
[0], " from ", lib
, (char *) NULL
);
3422 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3428 * This section contains a bunch of miscellaneous utility commands
3431 /* This implements the tcl command gdb_path_conv
3433 * On Windows, it canonicalizes the pathname,
3434 * On Unix, it is a no op.
3439 * The canonicalized path.
3443 gdb_path_conv (clientData
, interp
, objc
, objv
)
3444 ClientData clientData
;
3447 Tcl_Obj
*CONST objv
[];
3450 error ("wrong # args");
3454 char pathname
[256], *ptr
;
3456 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj (objv
[1], NULL
), pathname
);
3457 for (ptr
= pathname
; *ptr
; ptr
++)
3462 Tcl_SetStringObj (result_ptr
->obj_ptr
, pathname
, -1);
3465 Tcl_SetStringObj (result_ptr
->obj_ptr
, Tcl_GetStringFromObj (objv
[1], NULL
), -1);
3472 * This section has utility routines that are not Tcl commands.
3476 perror_with_name_wrapper (args
)
3479 perror_with_name (args
);
3483 /* The lookup_symtab() in symtab.c doesn't work correctly */
3484 /* It will not work will full pathnames and if multiple */
3485 /* source files have the same basename, it will return */
3486 /* the first one instead of the correct one. This version */
3487 /* also always makes sure symtab->fullname is set. */
3489 static struct symtab
*
3490 full_lookup_symtab(file
)
3494 struct objfile
*objfile
;
3495 char *bfile
, *fullname
;
3496 struct partial_symtab
*pt
;
3501 /* first try a direct lookup */
3502 st
= lookup_symtab (file
);
3506 symtab_to_filename(st
);
3510 /* if the direct approach failed, try */
3511 /* looking up the basename and checking */
3512 /* all matches with the fullname */
3513 bfile
= basename (file
);
3514 ALL_SYMTABS (objfile
, st
)
3516 if (!strcmp (bfile
, basename(st
->filename
)))
3519 fullname
= symtab_to_filename (st
);
3521 fullname
= st
->fullname
;
3523 if (!strcmp (file
, fullname
))
3528 /* still no luck? look at psymtabs */
3529 ALL_PSYMTABS (objfile
, pt
)
3531 if (!strcmp (bfile
, basename(pt
->filename
)))
3533 st
= PSYMTAB_TO_SYMTAB (pt
);
3536 fullname
= symtab_to_filename (st
);
3537 if (!strcmp (file
, fullname
))