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
), VALUE_ADDRESS (val
),
651 gdb_stdout
, 0, 0, 0, 0);
653 do_cleanups (old_chain
);
658 /* This implements the tcl command "gdb_cmd".
660 * It sends its argument to the GDB command scanner for execution.
661 * This command will never cause the update, idle and busy hooks to be called
665 * command - The GDB command to execute
667 * The output from the gdb command (except for the "load" & "while"
668 * which dump their output to the console.
672 gdb_cmd (clientData
, interp
, objc
, objv
)
673 ClientData clientData
;
676 Tcl_Obj
*CONST objv
[];
682 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
688 if (Tcl_GetBooleanFromObj (NULL
, objv
[2], &from_tty
) != TCL_OK
) {
689 Tcl_SetStringObj (result_ptr
->obj_ptr
, "from_tty must be a boolean.",
695 if (running_now
|| load_in_progress
)
700 /* for the load instruction (and possibly others later) we
701 set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
702 will not buffer all the data until the command is finished. */
704 if ((strncmp ("load ", Tcl_GetStringFromObj (objv
[1], NULL
), 5) == 0))
706 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
707 load_in_progress
= 1;
710 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), from_tty
);
712 if (load_in_progress
)
714 load_in_progress
= 0;
715 result_ptr
->flags
|= GDBTK_TO_RESULT
;
718 bpstat_do_actions (&stop_bpstat
);
724 * This implements the tcl command "gdb_immediate"
726 * It does exactly the same thing as gdb_cmd, except NONE of its outut
727 * is buffered. This will also ALWAYS cause the busy, update, and idle hooks to
728 * be called, contrasted with gdb_cmd, which NEVER calls them.
729 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
730 * to the console window.
733 * command - The GDB command to execute
739 gdb_immediate_command (clientData
, interp
, objc
, objv
)
740 ClientData clientData
;
743 Tcl_Obj
*CONST objv
[];
748 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
752 if (running_now
|| load_in_progress
)
757 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
759 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
761 bpstat_do_actions (&stop_bpstat
);
763 result_ptr
->flags
|= GDBTK_TO_RESULT
;
768 /* This implements the tcl command "gdb_prompt"
770 * It returns the gdb interpreter's prompt.
779 gdb_prompt_command (clientData
, interp
, objc
, objv
)
780 ClientData clientData
;
783 Tcl_Obj
*CONST objv
[];
785 Tcl_SetStringObj (result_ptr
->obj_ptr
, get_prompt (), -1);
791 * This section contains general informational commands.
794 /* This implements the tcl command "gdb_target_has_execution"
796 * Tells whether the target is executing.
801 * A boolean indicating whether the target is executing.
805 gdb_target_has_execution_command (clientData
, interp
, objc
, objv
)
806 ClientData clientData
;
809 Tcl_Obj
*CONST objv
[];
813 if (target_has_execution
&& inferior_pid
!= 0)
816 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, result
);
820 /* This implements the tcl command "gdb_load_info"
822 * It returns information about the file about to be downloaded.
825 * filename: The file to open & get the info on.
827 * A list consisting of the name and size of each section.
831 gdb_load_info (clientData
, interp
, objc
, objv
)
832 ClientData clientData
;
835 Tcl_Obj
*CONST objv
[];
838 struct cleanup
*old_cleanups
;
842 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
844 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
845 if (loadfile_bfd
== NULL
)
847 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Open failed", -1);
850 old_cleanups
= make_cleanup ((make_cleanup_func
) bfd_close
, loadfile_bfd
);
852 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
854 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Bad Object File", -1);
858 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
860 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
862 if (s
->flags
& SEC_LOAD
)
864 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
867 ob
[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd
, s
), -1);
868 ob
[1] = Tcl_NewLongObj ((long) size
);
869 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewListObj (2, ob
));
874 do_cleanups (old_cleanups
);
880 * This and gdb_get_locals just call gdb_get_vars_command with the right
881 * value of clientData. We can't use the client data in the definition
882 * of the command, because the call wrapper uses this instead...
886 gdb_get_locals_command (clientData
, interp
, objc
, objv
)
887 ClientData clientData
;
890 Tcl_Obj
*CONST objv
[];
893 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
898 gdb_get_args_command (clientData
, interp
, objc
, objv
)
899 ClientData clientData
;
902 Tcl_Obj
*CONST objv
[];
905 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
909 /* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
911 * This function sets the Tcl interpreter's result to a list of variable names
912 * depending on clientData. If clientData is one, the result is a list of
913 * arguments; zero returns a list of locals -- all relative to the block
914 * specified as an argument to the command. Valid commands include
915 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
919 * block - the address within which to specify the locals or args.
921 * A list of the locals or args
925 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
926 ClientData clientData
;
929 Tcl_Obj
*CONST objv
[];
931 struct symtabs_and_lines sals
;
934 char **canonical
, *args
;
935 int i
, nsyms
, arguments
;
939 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
,
940 "wrong # of args: should be \"",
941 Tcl_GetStringFromObj (objv
[0], NULL
),
942 " function:line|function|line|*addr\"", NULL
);
946 arguments
= (int) clientData
;
947 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
948 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
951 Tcl_SetStringObj (result_ptr
->obj_ptr
,
952 "error decoding line", -1);
956 /* Initialize the result pointer to an empty list. */
958 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
960 /* Resolve all line numbers to PC's */
961 for (i
= 0; i
< sals
.nelts
; i
++)
962 resolve_sal_pc (&sals
.sals
[i
]);
964 block
= block_for_pc (sals
.sals
[0].pc
);
967 nsyms
= BLOCK_NSYMS (block
);
968 for (i
= 0; i
< nsyms
; i
++)
970 sym
= BLOCK_SYM (block
, i
);
971 switch (SYMBOL_CLASS (sym
)) {
973 case LOC_UNDEF
: /* catches errors */
974 case LOC_CONST
: /* constant */
975 case LOC_TYPEDEF
: /* local typedef */
976 case LOC_LABEL
: /* local label */
977 case LOC_BLOCK
: /* local function */
978 case LOC_CONST_BYTES
: /* loc. byte seq. */
979 case LOC_UNRESOLVED
: /* unresolved static */
980 case LOC_OPTIMIZED_OUT
: /* optimized out */
982 case LOC_ARG
: /* argument */
983 case LOC_REF_ARG
: /* reference arg */
984 case LOC_REGPARM
: /* register arg */
985 case LOC_REGPARM_ADDR
: /* indirect register arg */
986 case LOC_LOCAL_ARG
: /* stack arg */
987 case LOC_BASEREG_ARG
: /* basereg arg */
989 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
990 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
992 case LOC_LOCAL
: /* stack local */
993 case LOC_BASEREG
: /* basereg local */
994 case LOC_STATIC
: /* static */
995 case LOC_REGISTER
: /* register */
997 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
998 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
1002 if (BLOCK_FUNCTION (block
))
1005 block
= BLOCK_SUPERBLOCK (block
);
1011 /* This implements the tcl command "gdb_get_line"
1013 * It returns the linenumber for a given linespec. It will take any spec
1014 * that can be passed to decode_line_1
1017 * linespec - the line specification
1019 * The line number for that spec.
1022 gdb_get_line_command (clientData
, interp
, objc
, objv
)
1023 ClientData clientData
;
1026 Tcl_Obj
*CONST objv
[];
1028 struct symtabs_and_lines sals
;
1029 char *args
, **canonical
;
1033 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1034 Tcl_GetStringFromObj (objv
[0], NULL
),
1035 " linespec\"", NULL
);
1039 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1040 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1041 if (sals
.nelts
== 1)
1043 Tcl_SetIntObj (result_ptr
->obj_ptr
, sals
.sals
[0].line
);
1047 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1052 /* This implements the tcl command "gdb_get_file"
1054 * It returns the file containing a given line spec.
1057 * linespec - The linespec to look up
1059 * The file containing it.
1063 gdb_get_file_command (clientData
, interp
, objc
, objv
)
1064 ClientData clientData
;
1067 Tcl_Obj
*CONST objv
[];
1069 struct symtabs_and_lines sals
;
1070 char *args
, **canonical
;
1074 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1075 Tcl_GetStringFromObj (objv
[0], NULL
),
1076 " linespec\"", NULL
);
1080 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1081 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1082 if (sals
.nelts
== 1)
1084 Tcl_SetStringObj (result_ptr
->obj_ptr
, sals
.sals
[0].symtab
->filename
, -1);
1088 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1092 /* This implements the tcl command "gdb_get_function"
1094 * It finds the function containing the given line spec.
1097 * linespec - The line specification
1099 * The function that contains it, or "N/A" if it is not in a function.
1102 gdb_get_function_command (clientData
, interp
, objc
, objv
)
1103 ClientData clientData
;
1106 Tcl_Obj
*CONST objv
[];
1109 struct symtabs_and_lines sals
;
1110 char *args
, **canonical
;
1114 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1115 Tcl_GetStringFromObj (objv
[0], NULL
),
1116 " linespec\"", NULL
);
1120 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1121 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1122 if (sals
.nelts
== 1)
1124 resolve_sal_pc (&sals
.sals
[0]);
1125 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
1126 if (function
!= NULL
)
1128 Tcl_SetStringObj (result_ptr
->obj_ptr
, function
, -1);
1133 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1137 /* This implements the tcl command "gdb_find_file"
1139 * It searches the symbol tables to get the full pathname to a file.
1142 * filename: the file name to search for.
1144 * The full path to the file, or an empty string if the file is not
1149 gdb_find_file_command (clientData
, interp
, objc
, objv
)
1150 ClientData clientData
;
1153 Tcl_Obj
*CONST objv
[];
1155 char *filename
= NULL
;
1160 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
1164 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1166 filename
= st
->fullname
;
1168 if (filename
== NULL
)
1169 Tcl_SetStringObj (result_ptr
->obj_ptr
, "", 0);
1171 Tcl_SetStringObj (result_ptr
->obj_ptr
, filename
, -1);
1176 /* This implements the tcl command "gdb_listfiles"
1178 * This lists all the files in the current executible.
1180 * Note that this currently pulls in all sorts of filenames
1181 * that aren't really part of the executable. It would be
1182 * best if we could check each file to see if it actually
1183 * contains executable lines of code, but we can't do that
1187 * ?pathname? - If provided, only files which match pathname
1188 * (up to strlen(pathname)) are included. THIS DOES NOT
1189 * CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1190 * THE FULL PATHNAME!!!
1193 * A list of all matching files.
1196 gdb_listfiles (clientData
, interp
, objc
, objv
)
1197 ClientData clientData
;
1200 Tcl_Obj
*CONST objv
[];
1202 struct objfile
*objfile
;
1203 struct partial_symtab
*psymtab
;
1204 struct symtab
*symtab
;
1205 char *lastfile
, *pathname
=NULL
, **files
;
1207 int i
, numfiles
= 0, len
= 0;
1210 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1214 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1218 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1220 ALL_PSYMTABS (objfile
, psymtab
)
1222 if (numfiles
== files_size
)
1224 files_size
= files_size
* 2;
1225 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1227 if (psymtab
->filename
)
1229 if (!len
|| !strncmp(pathname
, psymtab
->filename
,len
)
1230 || !strcmp(psymtab
->filename
, basename(psymtab
->filename
)))
1232 files
[numfiles
++] = basename(psymtab
->filename
);
1237 ALL_SYMTABS (objfile
, symtab
)
1239 if (numfiles
== files_size
)
1241 files_size
= files_size
* 2;
1242 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1244 if (symtab
->filename
&& symtab
->linetable
&& symtab
->linetable
->nitems
)
1246 if (!len
|| !strncmp(pathname
, symtab
->filename
,len
)
1247 || !strcmp(symtab
->filename
, basename(symtab
->filename
)))
1249 files
[numfiles
++] = basename(symtab
->filename
);
1254 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1258 /* Discard the old result pointer, in case it has accumulated anything
1259 and set it to a new list object */
1261 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1263 for (i
= 0; i
< numfiles
; i
++)
1265 if (strcmp(files
[i
],lastfile
))
1266 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj(files
[i
], -1));
1267 lastfile
= files
[i
];
1275 comp_files (file1
, file2
)
1276 const void *file1
, *file2
;
1278 return strcmp(* (char **) file1
, * (char **) file2
);
1282 /* This implements the tcl command "gdb_search"
1286 * option - One of "functions", "variables" or "types"
1287 * regexp - The regular expression to look for.
1296 gdb_search (clientData
, interp
, objc
, objv
)
1297 ClientData clientData
;
1300 Tcl_Obj
*CONST objv
[];
1302 struct symbol_search
*ss
= NULL
;
1303 struct symbol_search
*p
;
1304 struct cleanup
*old_chain
= NULL
;
1305 Tcl_Obj
*CONST
*switch_objv
;
1306 int index
, switch_objc
, i
;
1307 namespace_enum space
= 0;
1309 int static_only
, nfiles
;
1310 Tcl_Obj
**file_list
;
1312 static char *search_options
[] = { "functions", "variables", "types", (char *) NULL
};
1313 static char *switches
[] = { "-files", "-static", (char *) NULL
};
1314 enum search_opts
{ SEARCH_FUNCTIONS
, SEARCH_VARIABLES
, SEARCH_TYPES
};
1315 enum switches_opts
{ SWITCH_FILES
, SWITCH_STATIC_ONLY
};
1319 Tcl_WrongNumArgs (interp
, 1, objv
, "option regexp ?arg ...?");
1320 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1324 if (Tcl_GetIndexFromObj (interp
, objv
[1], search_options
, "option", 0,
1327 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1331 /* Unfortunately, we cannot teach search_symbols to search on
1332 multiple regexps, so we have to do a two-tier search for
1333 any searches which choose to narrow the playing field. */
1334 switch ((enum search_opts
) index
)
1336 case SEARCH_FUNCTIONS
:
1337 space
= FUNCTIONS_NAMESPACE
; break;
1338 case SEARCH_VARIABLES
:
1339 space
= VARIABLES_NAMESPACE
; break;
1341 space
= TYPES_NAMESPACE
; break;
1344 regexp
= Tcl_GetStringFromObj (objv
[2], NULL
);
1345 /* Process any switches that refine the search */
1346 switch_objc
= objc
- 3;
1347 switch_objv
= objv
+ 3;
1351 files
= (char **) NULL
;
1352 while (switch_objc
> 0)
1354 if (Tcl_GetIndexFromObj (interp
, switch_objv
[0], switches
,
1355 "option", 0, &index
) != TCL_OK
)
1357 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1361 switch ((enum switches_opts
) index
)
1366 if (switch_objc
< 2)
1368 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList -static 1|0]");
1369 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1372 result
= Tcl_ListObjGetElements (interp
, switch_objv
[1], &nfiles
, &file_list
);
1373 if (result
!= TCL_OK
)
1376 files
= (char **) xmalloc (nfiles
* sizeof (char *));
1377 for (i
= 0; i
< nfiles
; i
++)
1378 files
[i
] = Tcl_GetStringFromObj (file_list
[i
], NULL
);
1383 case SWITCH_STATIC_ONLY
:
1384 if (switch_objc
< 2)
1386 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList] [-static 1|0]");
1387 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1390 if ( Tcl_GetBooleanFromObj (interp
, switch_objv
[1], &static_only
) !=
1392 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1402 search_symbols (regexp
, space
, nfiles
, files
, &ss
);
1404 old_chain
= make_cleanup ((make_cleanup_func
) free_search_symbols
, ss
);
1406 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1408 for (p
= ss
; p
!= NULL
; p
= p
->next
)
1412 if (static_only
&& p
->block
!= STATIC_BLOCK
)
1415 /* Strip off some C++ special symbols, like RTTI and global
1416 constructors/destructors. */
1417 if ((p
->symbol
!= NULL
&& !STREQN (SYMBOL_NAME (p
->symbol
), "__tf", 4)
1418 && !STREQN (SYMBOL_NAME (p
->symbol
), "_GLOBAL_", 8))
1419 || p
->msymbol
!= NULL
)
1421 elem
= Tcl_NewListObj (0, NULL
);
1423 if (p
->msymbol
== NULL
)
1424 Tcl_ListObjAppendElement (interp
, elem
,
1425 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->symbol
), -1));
1427 Tcl_ListObjAppendElement (interp
, elem
,
1428 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->msymbol
), -1));
1430 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, elem
);
1435 do_cleanups (old_chain
);
1440 /* This implements the tcl command gdb_listfuncs
1442 * It lists all the functions defined in a given file
1445 * file - the file to look in
1447 * A list of two element lists, the first element is
1448 * the symbol name, and the second is a boolean indicating
1449 * whether the symbol is demangled (1 for yes).
1453 gdb_listfuncs (clientData
, interp
, objc
, objv
)
1454 ClientData clientData
;
1457 Tcl_Obj
*CONST objv
[];
1459 struct symtab
*symtab
;
1460 struct blockvector
*bv
;
1464 Tcl_Obj
*funcVals
[2];
1468 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1471 symtab
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1474 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No such file", -1);
1478 if (mangled
== NULL
)
1480 mangled
= Tcl_NewBooleanObj(1);
1481 not_mangled
= Tcl_NewBooleanObj(0);
1482 Tcl_IncrRefCount(mangled
);
1483 Tcl_IncrRefCount(not_mangled
);
1486 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1488 bv
= BLOCKVECTOR (symtab
);
1489 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1491 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1492 /* Skip the sort if this block is always sorted. */
1493 if (!BLOCK_SHOULD_SORT (b
))
1494 sort_block_syms (b
);
1495 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1497 sym
= BLOCK_SYM (b
, j
);
1498 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1501 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1504 /* strip out "global constructors" and "global destructors" */
1505 /* because we aren't interested in them. */
1506 if (strncmp (name
, "global ", 7))
1508 funcVals
[0] = Tcl_NewStringObj(name
, -1);
1509 funcVals
[1] = mangled
;
1517 funcVals
[0] = Tcl_NewStringObj(SYMBOL_NAME(sym
), -1);
1518 funcVals
[1] = not_mangled
;
1520 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1521 Tcl_NewListObj (2, funcVals
));
1530 * This section contains all the commands that act on the registers:
1533 /* This is a sort of mapcar function for operations on registers */
1536 map_arg_registers (objc
, objv
, func
, argp
)
1538 Tcl_Obj
*CONST objv
[];
1539 void (*func
) PARAMS ((int regnum
, void *argp
));
1544 /* Note that the test for a valid register must include checking the
1545 REGISTER_NAME because NUM_REGS may be allocated for the union of
1546 the register sets within a family of related processors. In this
1547 case, some entries of REGISTER_NAME will change depending upon
1548 the particular processor being debugged. */
1550 if (objc
== 0) /* No args, just do all the regs */
1554 && REGISTER_NAME (regnum
) != NULL
1555 && *REGISTER_NAME (regnum
) != '\000';
1557 func (regnum
, argp
);
1562 /* Else, list of register #s, just do listed regs */
1563 for (; objc
> 0; objc
--, objv
++)
1565 if (Tcl_GetIntFromObj (NULL
, *objv
, ®num
) != TCL_OK
)
1567 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1572 && regnum
< NUM_REGS
1573 && REGISTER_NAME (regnum
) != NULL
1574 && *REGISTER_NAME (regnum
) != '\000')
1575 func (regnum
, argp
);
1578 Tcl_SetStringObj (result_ptr
->obj_ptr
, "bad register number", -1);
1586 /* This implements the TCL command `gdb_regnames', which returns a list of
1587 all of the register names. */
1590 gdb_regnames (clientData
, interp
, objc
, objv
)
1591 ClientData clientData
;
1594 Tcl_Obj
*CONST objv
[];
1599 return map_arg_registers (objc
, objv
, get_register_name
, NULL
);
1603 get_register_name (regnum
, argp
)
1605 void *argp
; /* Ignored */
1607 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1608 Tcl_NewStringObj (REGISTER_NAME (regnum
), -1));
1611 /* This implements the tcl command gdb_fetch_registers
1612 * Pass it a list of register names, and it will
1613 * return their values as a list.
1616 * format: The format string for printing the values
1617 * args: the registers to look for
1619 * A list of their values.
1623 gdb_fetch_registers (clientData
, interp
, objc
, objv
)
1624 ClientData clientData
;
1627 Tcl_Obj
*CONST objv
[];
1633 Tcl_SetStringObj (result_ptr
->obj_ptr
,
1634 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
1638 format
= *(Tcl_GetStringFromObj(objv
[0], NULL
));
1642 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Output the results as a list */
1643 result
= map_arg_registers (objc
, objv
, get_register
, (void *) format
);
1644 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
1650 get_register (regnum
, fp
)
1654 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1655 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
1656 int format
= (int)fp
;
1662 /* read_relative_register_raw_bytes returns a virtual frame pointer
1663 (FRAME_FP (selected_frame)) if regnum == FP_REGNUM instead
1664 of the real contents of the register. To get around this,
1665 use get_saved_register instead. */
1666 get_saved_register (raw_buffer
, &optim
, (CORE_ADDR
*) NULL
, selected_frame
,
1667 regnum
, (enum lval_type
*) NULL
);
1670 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1671 Tcl_NewStringObj ("Optimized out", -1));
1675 /* Convert raw data to virtual format if necessary. */
1677 if (REGISTER_CONVERTIBLE (regnum
))
1679 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
1680 raw_buffer
, virtual_buffer
);
1683 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1688 printf_filtered ("0x");
1689 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1691 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1692 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1693 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
1697 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
1698 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1702 /* This implements the tcl command get_pc_reg
1703 * It returns the value of the PC register
1708 * The value of the pc register.
1712 get_pc_register (clientData
, interp
, objc
, objv
)
1713 ClientData clientData
;
1716 Tcl_Obj
*CONST objv
[];
1720 sprintf (buff
, "0x%llx",(long long) read_register (PC_REGNUM
));
1721 Tcl_SetStringObj(result_ptr
->obj_ptr
, buff
, -1);
1725 /* This implements the tcl command "gdb_changed_register_list"
1726 * It takes a list of registers, and returns a list of
1727 * the registers on that list that have changed since the last
1728 * time the proc was called.
1731 * A list of registers.
1733 * A list of changed registers.
1737 gdb_changed_register_list (clientData
, interp
, objc
, objv
)
1738 ClientData clientData
;
1741 Tcl_Obj
*CONST objv
[];
1746 return map_arg_registers (objc
, objv
, register_changed_p
, NULL
);
1750 register_changed_p (regnum
, argp
)
1752 void *argp
; /* Ignored */
1754 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1756 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1759 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1760 REGISTER_RAW_SIZE (regnum
)) == 0)
1763 /* Found a changed register. Save new value and return its number. */
1765 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1766 REGISTER_RAW_SIZE (regnum
));
1768 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(regnum
));
1772 * This section contains the commands that deal with tracepoints:
1775 /* return a list of all tracepoint numbers in interpreter */
1777 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
1778 ClientData clientData
;
1781 Tcl_Obj
*CONST objv
[];
1783 struct tracepoint
*tp
;
1785 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1787 ALL_TRACEPOINTS (tp
)
1788 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->number
));
1793 /* returns -1 if not found, tracepoint # if found */
1795 tracepoint_exists (char * args
)
1797 struct tracepoint
*tp
;
1799 struct symtabs_and_lines sals
;
1803 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1804 if (sals
.nelts
== 1)
1806 resolve_sal_pc (&sals
.sals
[0]);
1807 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
1808 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
1811 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
1812 strcat (file
, sals
.sals
[0].symtab
->filename
);
1814 ALL_TRACEPOINTS (tp
)
1816 if (tp
->address
== sals
.sals
[0].pc
)
1817 result
= tp
->number
;
1819 /* Why is this here? This messes up assembly traces */
1820 else if (tp
->source_file
!= NULL
1821 && strcmp (tp
->source_file
, file
) == 0
1822 && sals
.sals
[0].line
== tp
->line_number
)
1823 result
= tp
->number
;
1834 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
1835 ClientData clientData
;
1838 Tcl_Obj
*CONST objv
[];
1844 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1845 Tcl_GetStringFromObj (objv
[0], NULL
),
1846 " function:line|function|line|*addr\"", NULL
);
1850 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1852 Tcl_SetIntObj (result_ptr
->obj_ptr
, tracepoint_exists (args
));
1857 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
1858 ClientData clientData
;
1861 Tcl_Obj
*CONST objv
[];
1863 struct symtab_and_line sal
;
1865 struct tracepoint
*tp
;
1866 struct action_line
*al
;
1867 Tcl_Obj
*action_list
;
1868 char *filename
, *funcname
, *fname
;
1873 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1877 if (Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
) != TCL_OK
)
1879 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1883 ALL_TRACEPOINTS (tp
)
1884 if (tp
->number
== tpnum
)
1890 sprintf (buff
, "Tracepoint #%d does not exist", tpnum
);
1891 Tcl_SetStringObj (result_ptr
->obj_ptr
, buff
, -1);
1895 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1896 sal
= find_pc_line (tp
->address
, 0);
1897 filename
= symtab_to_filename (sal
.symtab
);
1898 if (filename
== NULL
)
1900 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1901 Tcl_NewStringObj (filename
, -1));
1903 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
1904 fname
= cplus_demangle (funcname
, 0);
1907 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj
1912 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj
1915 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (sal
.line
));
1916 sprintf (tmp
, "0x%lx", tp
->address
);
1917 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (tmp
, -1));
1918 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->enabled
));
1919 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->pass_count
));
1920 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->step_count
));
1921 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->thread
));
1922 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->hit_count
));
1924 /* Append a list of actions */
1925 action_list
= Tcl_NewObj ();
1926 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
1928 Tcl_ListObjAppendElement (interp
, action_list
,
1929 Tcl_NewStringObj (al
->action
, -1));
1931 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, action_list
);
1938 gdb_trace_status (clientData
, interp
, objc
, objv
)
1939 ClientData clientData
;
1942 Tcl_Obj
*CONST objv
[];
1946 if (trace_running_p
)
1949 Tcl_SetIntObj (result_ptr
->obj_ptr
, result
);
1956 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
1957 ClientData clientData
;
1960 Tcl_Obj
*CONST objv
[];
1964 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1965 Tcl_GetStringFromObj (objv
[0], NULL
),
1966 " linespec\"", NULL
);
1970 Tcl_SetIntObj (result_ptr
->obj_ptr
, get_traceframe_number ());
1975 /* This implements the tcl command gdb_actions
1976 * It sets actions for a given tracepoint.
1979 * number: the tracepoint in question
1980 * actions: the actions to add to this tracepoint
1986 gdb_actions_command (clientData
, interp
, objc
, objv
)
1987 ClientData clientData
;
1990 Tcl_Obj
*CONST objv
[];
1992 struct tracepoint
*tp
;
1994 int nactions
, i
, len
;
1995 char *number
, *args
, *action
;
1997 struct action_line
*next
= NULL
, *temp
;
1998 enum actionline_type linetype
;
2002 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # args: should be: \"",
2003 Tcl_GetStringFromObj (objv
[0], NULL
),
2004 " number actions\"", NULL
);
2008 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
2009 tp
= get_tracepoint_by_number (&args
);
2012 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "Tracepoint \"", number
, "\" does not exist", NULL
);
2016 /* Free any existing actions */
2017 if (tp
->actions
!= NULL
)
2022 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
2024 /* Add the actions to the tracepoint */
2025 for (i
= 0; i
< nactions
; i
++)
2027 temp
= xmalloc (sizeof (struct action_line
));
2029 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
2030 temp
->action
= savestring (action
, len
);
2032 linetype
= validate_actionline (&(temp
->action
), tp
);
2034 if (linetype
== BADLINE
)
2056 * This section has commands that handle source disassembly.
2059 /* This implements the tcl command gdb_disassemble
2062 * source_with_assm - must be "source" or "nosource"
2063 * low_address - the address from which to start disassembly
2064 * ?hi_address? - the address to which to disassemble, defaults
2065 * to the end of the function containing low_address.
2067 * The disassembled code is passed to fputs_unfiltered, so it
2068 * either goes to the console if result_ptr->obj_ptr is NULL or to
2073 gdb_disassemble (clientData
, interp
, objc
, objv
)
2074 ClientData clientData
;
2077 Tcl_Obj
*CONST objv
[];
2079 CORE_ADDR pc
, low
, high
;
2080 int mixed_source_and_assembly
;
2081 static disassemble_info di
;
2082 static int di_initialized
;
2085 if (objc
!= 3 && objc
!= 4)
2086 error ("wrong # args");
2088 if (! di_initialized
)
2090 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
2091 (fprintf_ftype
) fprintf_unfiltered
);
2092 di
.flavour
= bfd_target_unknown_flavour
;
2093 di
.memory_error_func
= dis_asm_memory_error
;
2094 di
.print_address_func
= dis_asm_print_address
;
2098 di
.mach
= TARGET_PRINT_INSN_INFO
->mach
;
2099 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
2100 di
.endian
= BFD_ENDIAN_BIG
;
2102 di
.endian
= BFD_ENDIAN_LITTLE
;
2104 arg_ptr
= Tcl_GetStringFromObj (objv
[1], NULL
);
2105 if (*arg_ptr
== 's' && strcmp (arg_ptr
, "source") == 0)
2106 mixed_source_and_assembly
= 1;
2107 else if (*arg_ptr
== 'n' && strcmp (arg_ptr
, "nosource") == 0)
2108 mixed_source_and_assembly
= 0;
2110 error ("First arg must be 'source' or 'nosource'");
2112 low
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[2], NULL
));
2116 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
2117 error ("No function contains specified address");
2120 high
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[3], NULL
));
2122 /* If disassemble_from_exec == -1, then we use the following heuristic to
2123 determine whether or not to do disassembly from target memory or from the
2126 If we're debugging a local process, read target memory, instead of the
2127 exec file. This makes disassembly of functions in shared libs work
2130 Else, we're debugging a remote process, and should disassemble from the
2131 exec file for speed. However, this is no good if the target modifies its
2132 code (for relocation, or whatever).
2135 if (disassemble_from_exec
== -1)
2137 if (strcmp (target_shortname
, "child") == 0
2138 || strcmp (target_shortname
, "procfs") == 0
2139 || strcmp (target_shortname
, "vxprocess") == 0)
2140 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
2142 disassemble_from_exec
= 1; /* It's remote, read the exec file */
2145 if (disassemble_from_exec
)
2146 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
2148 di
.read_memory_func
= dis_asm_read_memory
;
2150 /* If just doing straight assembly, all we need to do is disassemble
2151 everything between low and high. If doing mixed source/assembly, we've
2152 got a totally different path to follow. */
2154 if (mixed_source_and_assembly
)
2155 { /* Come here for mixed source/assembly */
2156 /* The idea here is to present a source-O-centric view of a function to
2157 the user. This means that things are presented in source order, with
2158 (possibly) out of order assembly immediately following. */
2159 struct symtab
*symtab
;
2160 struct linetable_entry
*le
;
2163 struct my_line_entry
*mle
;
2164 struct symtab_and_line sal
;
2169 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
2171 if (!symtab
|| !symtab
->linetable
)
2174 /* First, convert the linetable to a bunch of my_line_entry's. */
2176 le
= symtab
->linetable
->item
;
2177 nlines
= symtab
->linetable
->nitems
;
2182 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
2186 /* Copy linetable entries for this function into our data structure, creating
2187 end_pc's and setting out_of_order as appropriate. */
2189 /* First, skip all the preceding functions. */
2191 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
2193 /* Now, copy all entries before the end of this function. */
2196 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
2198 if (le
[i
].line
== le
[i
+ 1].line
2199 && le
[i
].pc
== le
[i
+ 1].pc
)
2200 continue; /* Ignore duplicates */
2202 mle
[newlines
].line
= le
[i
].line
;
2203 if (le
[i
].line
> le
[i
+ 1].line
)
2205 mle
[newlines
].start_pc
= le
[i
].pc
;
2206 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
2210 /* If we're on the last line, and it's part of the function, then we need to
2211 get the end pc in a special way. */
2216 mle
[newlines
].line
= le
[i
].line
;
2217 mle
[newlines
].start_pc
= le
[i
].pc
;
2218 sal
= find_pc_line (le
[i
].pc
, 0);
2219 mle
[newlines
].end_pc
= sal
.end
;
2223 /* Now, sort mle by line #s (and, then by addresses within lines). */
2226 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
2228 /* Now, for each line entry, emit the specified lines (unless they have been
2229 emitted before), followed by the assembly code for that line. */
2231 next_line
= 0; /* Force out first line */
2232 for (i
= 0; i
< newlines
; i
++)
2234 /* Print out everything from next_line to the current line. */
2236 if (mle
[i
].line
>= next_line
)
2239 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
2241 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
2243 next_line
= mle
[i
].line
+ 1;
2246 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
2249 fputs_unfiltered (" ", gdb_stdout
);
2250 print_address (pc
, gdb_stdout
);
2251 fputs_unfiltered (":\t ", gdb_stdout
);
2252 pc
+= (*tm_print_insn
) (pc
, &di
);
2253 fputs_unfiltered ("\n", gdb_stdout
);
2260 for (pc
= low
; pc
< high
; )
2263 fputs_unfiltered (" ", gdb_stdout
);
2264 print_address (pc
, gdb_stdout
);
2265 fputs_unfiltered (":\t ", gdb_stdout
);
2266 pc
+= (*tm_print_insn
) (pc
, &di
);
2267 fputs_unfiltered ("\n", gdb_stdout
);
2271 gdb_flush (gdb_stdout
);
2276 /* This is the memory_read_func for gdb_disassemble when we are
2277 disassembling from the exec file. */
2280 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
2284 disassemble_info
*info
;
2286 extern struct target_ops exec_ops
;
2290 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
2301 /* This will be passed to qsort to sort the results of the disassembly */
2304 compare_lines (mle1p
, mle2p
)
2308 struct my_line_entry
*mle1
, *mle2
;
2311 mle1
= (struct my_line_entry
*) mle1p
;
2312 mle2
= (struct my_line_entry
*) mle2p
;
2314 val
= mle1
->line
- mle2
->line
;
2319 return mle1
->start_pc
- mle2
->start_pc
;
2322 /* This implements the TCL command `gdb_loc',
2325 * ?symbol? The symbol or address to locate - defaults to pc
2327 * a list consisting of the following:
2328 * basename, function name, filename, line number, address, current pc
2332 gdb_loc (clientData
, interp
, objc
, objv
)
2333 ClientData clientData
;
2336 Tcl_Obj
*CONST objv
[];
2339 struct symtab_and_line sal
;
2340 char *funcname
, *fname
;
2343 if (!have_full_symbols () && !have_partial_symbols ())
2345 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No symbol table is loaded", -1);
2351 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
2353 /* Note - this next line is not correct on all architectures. */
2354 /* For a graphical debugger we really want to highlight the */
2355 /* assembly line that called the next function on the stack. */
2356 /* Many architectures have the next instruction saved as the */
2357 /* pc on the stack, so what happens is the next instruction is hughlighted. */
2359 pc
= selected_frame
->pc
;
2360 sal
= find_pc_line (selected_frame
->pc
,
2361 selected_frame
->next
!= NULL
2362 && !selected_frame
->next
->signal_handler_caller
2363 && !frame_in_dummy (selected_frame
->next
));
2368 sal
= find_pc_line (stop_pc
, 0);
2373 struct symtabs_and_lines sals
;
2376 sals
= decode_line_spec (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
2382 if (sals
.nelts
!= 1)
2384 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Ambiguous line spec", -1);
2391 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
2396 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2397 Tcl_NewStringObj (sal
.symtab
->filename
, -1));
2399 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewStringObj ("", 0));
2401 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
2402 fname
= cplus_demangle (funcname
, 0);
2405 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2406 Tcl_NewStringObj (fname
, -1));
2410 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2411 Tcl_NewStringObj (funcname
, -1));
2413 filename
= symtab_to_filename (sal
.symtab
);
2414 if (filename
== NULL
)
2417 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2418 Tcl_NewStringObj (filename
, -1));
2419 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(sal
.line
)); /* line number */
2420 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
2421 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
2425 /* This implements the Tcl command 'gdb_get_mem', which
2426 * dumps a block of memory
2428 * gdb_get_mem addr form size num aschar
2430 * addr: address of data to dump
2431 * form: a char indicating format
2432 * size: size of each element; 1,2,4, or 8 bytes
2433 * num: the number of bytes to read
2434 * acshar: an optional ascii character to use in ASCII dump
2437 * a list of elements followed by an optional ASCII dump
2441 gdb_get_mem (clientData
, interp
, objc
, objv
)
2442 ClientData clientData
;
2445 Tcl_Obj
*CONST objv
[];
2447 int size
, asize
, i
, j
, bc
;
2449 int nbytes
, rnum
, bpr
;
2451 char format
, c
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
2452 struct type
*val_type
;
2454 if (objc
< 6 || objc
> 7)
2456 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2457 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2461 if (Tcl_GetIntFromObj (interp
, objv
[3], &size
) != TCL_OK
)
2463 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2468 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid size, must be > 0", -1);
2472 if (Tcl_GetIntFromObj (interp
, objv
[4], &nbytes
) != TCL_OK
)
2474 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2479 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid number of bytes, must be > 0",
2484 if (Tcl_GetIntFromObj (interp
, objv
[5], &bpr
) != TCL_OK
)
2486 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2491 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid bytes per row, must be > 0", -1);
2495 if (Tcl_GetLongFromObj (interp
, objv
[1], &tmp
) != TCL_OK
)
2498 addr
= (CORE_ADDR
) tmp
;
2500 format
= *(Tcl_GetStringFromObj (objv
[2], NULL
));
2501 mbuf
= (char *)malloc (nbytes
+32);
2504 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Out of memory.", -1);
2508 memset (mbuf
, 0, nbytes
+32);
2511 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
2514 aschar
= *(Tcl_GetStringFromObj(objv
[6], NULL
));
2520 val_type
= builtin_type_char
;
2524 val_type
= builtin_type_short
;
2528 val_type
= builtin_type_int
;
2532 val_type
= builtin_type_long_long
;
2536 val_type
= builtin_type_char
;
2540 bc
= 0; /* count of bytes in a row */
2541 buff
[0] = '"'; /* buffer for ascii dump */
2542 bptr
= &buff
[1]; /* pointer for ascii dump */
2544 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Build up the result as a list... */
2546 for (i
=0; i
< nbytes
; i
+= size
)
2550 fputs_unfiltered ("N/A ", gdb_stdout
);
2552 for ( j
= 0; j
< size
; j
++)
2557 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
2561 for ( j
= 0; j
< size
; j
++)
2564 if (c
< 32 || c
> 126)
2576 if (aschar
&& (bc
>= bpr
))
2578 /* end of row. print it and reset variables */
2583 fputs_unfiltered (buff
, gdb_stdout
);
2588 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
2596 /* This implements the tcl command "gdb_loadfile"
2597 * It loads a c source file into a text widget.
2600 * widget: the name of the text widget to fill
2601 * filename: the name of the file to load
2602 * linenumbers: A boolean indicating whether or not to display line numbers.
2607 /* In this routine, we will build up a "line table", i.e. a
2608 * table of bits showing which lines in the source file are executible.
2609 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2611 * Its size limits the maximum number of lines
2612 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2613 * the file is loaded, so it is OK to make this very large.
2614 * Additional memory will be allocated if needed. */
2615 #define LTABLE_SIZE 20000
2617 gdb_loadfile (clientData
, interp
, objc
, objv
)
2618 ClientData clientData
;
2621 Tcl_Obj
*CONST objv
[];
2623 char *file
, *widget
;
2624 int linenumbers
, ln
, lnum
, ltable_size
;
2627 struct symtab
*symtab
;
2628 struct linetable_entry
*le
;
2631 Tcl_DString text_cmd_1
, text_cmd_2
, *cur_cmd
;
2632 char line
[1024], line_num_buf
[16];
2633 int prefix_len_1
, prefix_len_2
, cur_prefix_len
, widget_len
;
2638 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
2642 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
2643 if ( Tk_NameToWindow (interp
, widget
, Tk_MainWindow (interp
)) == NULL
)
2648 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
2649 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
2651 symtab
= full_lookup_symtab (file
);
2654 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "File not found in symtab", -1);
2659 file
= symtab_to_filename ( symtab
);
2660 if ((fp
= fopen ( file
, "r" )) == NULL
)
2662 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Can't open file for reading", -1);
2666 if (stat (file
, &st
) < 0)
2668 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
2673 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
2674 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
2676 mtime
= bfd_get_mtime(exec_bfd
);
2678 if (mtime
&& mtime
< st
.st_mtime
)
2679 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2682 /* Source linenumbers don't appear to be in order, and a sort is */
2683 /* too slow so the fastest solution is just to allocate a huge */
2684 /* array and set the array entry for each linenumber */
2686 ltable_size
= LTABLE_SIZE
;
2687 ltable
= (char *)malloc (LTABLE_SIZE
);
2690 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2695 memset (ltable
, 0, LTABLE_SIZE
);
2697 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
2699 le
= symtab
->linetable
->item
;
2700 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
2702 lnum
= le
->line
>> 3;
2703 if (lnum
>= ltable_size
)
2706 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
2707 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
2709 if (new_ltable
== NULL
)
2711 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2716 ltable
= new_ltable
;
2718 ltable
[lnum
] |= 1 << (le
->line
% 8);
2722 Tcl_DStringInit(&text_cmd_1
);
2723 Tcl_DStringInit(&text_cmd_2
);
2727 widget_len
= strlen (widget
);
2730 Tcl_DStringAppend (&text_cmd_1
, widget
, widget_len
);
2731 Tcl_DStringAppend (&text_cmd_2
, widget
, widget_len
);
2735 Tcl_DStringAppend (&text_cmd_1
, " insert end {-\t", -1);
2736 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2738 Tcl_DStringAppend (&text_cmd_2
, " insert end { \t", -1);
2739 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2741 while (fgets (line
+ 1, 980, fp
))
2743 sprintf (line_num_buf
, "%d", ln
);
2744 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2746 cur_cmd
= &text_cmd_1
;
2747 cur_prefix_len
= prefix_len_1
;
2748 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2749 Tcl_DStringAppend (cur_cmd
, "} break_rgn_tag", 15);
2753 cur_cmd
= &text_cmd_2
;
2754 cur_prefix_len
= prefix_len_2
;
2755 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2756 Tcl_DStringAppend (cur_cmd
, "} \"\"", 4);
2759 Tcl_DStringAppendElement (cur_cmd
, line
);
2760 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2762 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2763 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2769 Tcl_DStringAppend (&text_cmd_1
, " insert end {- } break_rgn_tag", -1);
2770 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2771 Tcl_DStringAppend (&text_cmd_2
, " insert end { } \"\"", -1);
2772 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2774 while (fgets (line
+ 1, 980, fp
))
2776 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2778 cur_cmd
= &text_cmd_1
;
2779 cur_prefix_len
= prefix_len_1
;
2783 cur_cmd
= &text_cmd_2
;
2784 cur_prefix_len
= prefix_len_2
;
2787 Tcl_DStringAppendElement (cur_cmd
, line
);
2788 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2790 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2791 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2797 Tcl_DStringFree (&text_cmd_1
);
2798 Tcl_DStringFree (&text_cmd_2
);
2805 * This section contains commands for manipulation of breakpoints.
2809 /* set a breakpoint by source file and line number */
2810 /* flags are as follows: */
2811 /* least significant 2 bits are disposition, rest is */
2812 /* type (normally 0).
2815 bp_breakpoint, Normal breakpoint
2816 bp_hardware_breakpoint, Hardware assisted breakpoint
2819 Disposition of breakpoint. Ie: what to do after hitting it.
2822 del_at_next_stop, Delete at next stop, whether hit or not
2824 donttouch Leave it alone
2828 /* This implements the tcl command "gdb_set_bp"
2829 * It sets breakpoints, and runs the Tcl command
2830 * gdbtk_tcl_breakpoint create
2831 * to register the new breakpoint with the GUI.
2834 * filename: the file in which to set the breakpoint
2835 * line: the line number for the breakpoint
2836 * type: the type of the breakpoint
2837 * thread: optional thread number
2839 * The return value of the call to gdbtk_tcl_breakpoint.
2843 gdb_set_bp (clientData
, interp
, objc
, objv
)
2844 ClientData clientData
;
2847 Tcl_Obj
*CONST objv
[];
2850 struct symtab_and_line sal
;
2851 int line
, flags
, ret
, thread
= -1;
2852 struct breakpoint
*b
;
2856 if (objc
!= 4 && objc
!= 5)
2858 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type [thread]");
2862 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
2863 if (sal
.symtab
== NULL
)
2866 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
2868 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2872 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
2874 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2880 if (Tcl_GetIntFromObj( interp
, objv
[4], &thread
) == TCL_ERROR
)
2882 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2888 if (!find_line_pc (sal
.symtab
, sal
.line
, &sal
.pc
))
2891 sal
.section
= find_pc_overlay (sal
.pc
);
2892 b
= set_raw_breakpoint (sal
);
2893 set_breakpoint_count (breakpoint_count
+ 1);
2894 b
->number
= breakpoint_count
;
2895 b
->type
= flags
>> 2;
2896 b
->disposition
= flags
& 3;
2899 /* FIXME: this won't work for duplicate basenames! */
2900 sprintf (buf
, "%s:%d", basename (Tcl_GetStringFromObj ( objv
[1], NULL
)), line
);
2901 b
->addr_string
= strsave (buf
);
2903 /* now send notification command back to GUI */
2905 Tcl_DStringInit (&cmd
);
2907 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2908 sprintf (buf
, "%d", b
->number
);
2909 Tcl_DStringAppendElement(&cmd
, buf
);
2910 sprintf (buf
, "0x%lx", (long)sal
.pc
);
2911 Tcl_DStringAppendElement (&cmd
, buf
);
2912 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[2], NULL
));
2913 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[1], NULL
));
2914 Tcl_DStringAppendElement (&cmd
, bpdisp
[b
->disposition
]);
2915 sprintf (buf
, "%d", b
->enable
);
2916 Tcl_DStringAppendElement (&cmd
, buf
);
2917 sprintf (buf
, "%d", b
->thread
);
2918 Tcl_DStringAppendElement (&cmd
, buf
);
2921 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2922 Tcl_DStringFree (&cmd
);
2926 /* This implements the tcl command "gdb_set_bp_addr"
2927 * It sets breakpoints, and runs the Tcl command
2928 * gdbtk_tcl_breakpoint create
2929 * to register the new breakpoint with the GUI.
2932 * addr: the address at which to set the breakpoint
2933 * type: the type of the breakpoint
2934 * thread: optional thread number
2936 * The return value of the call to gdbtk_tcl_breakpoint.
2940 gdb_set_bp_addr (clientData
, interp
, objc
, objv
)
2941 ClientData clientData
;
2944 Tcl_Obj
*CONST objv
[];
2947 struct symtab_and_line sal
;
2948 int line
, flags
, ret
, thread
= -1;
2950 struct breakpoint
*b
;
2951 char *filename
, buf
[64];
2954 if (objc
!= 4 && objc
!= 3)
2956 Tcl_WrongNumArgs(interp
, 1, objv
, "addr type ?thread?");
2960 if (Tcl_GetLongFromObj( interp
, objv
[1], &addr
) == TCL_ERROR
)
2962 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2966 if (Tcl_GetIntFromObj( interp
, objv
[2], &flags
) == TCL_ERROR
)
2968 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2974 if (Tcl_GetIntFromObj( interp
, objv
[3], &thread
) == TCL_ERROR
)
2976 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2981 sal
= find_pc_line (addr
, 0);
2983 b
= set_raw_breakpoint (sal
);
2984 set_breakpoint_count (breakpoint_count
+ 1);
2985 b
->number
= breakpoint_count
;
2986 b
->type
= flags
>> 2;
2987 b
->disposition
= flags
& 3;
2990 sprintf (buf
, "*(0x%lx)",addr
);
2991 b
->addr_string
= strsave (buf
);
2993 /* now send notification command back to GUI */
2995 Tcl_DStringInit (&cmd
);
2997 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2998 sprintf (buf
, "%d", b
->number
);
2999 Tcl_DStringAppendElement(&cmd
, buf
);
3000 sprintf (buf
, "0x%lx", addr
);
3001 Tcl_DStringAppendElement (&cmd
, buf
);
3002 sprintf (buf
, "%d", b
->line_number
);
3003 Tcl_DStringAppendElement (&cmd
, buf
);
3005 filename
= symtab_to_filename (sal
.symtab
);
3006 if (filename
== NULL
)
3008 Tcl_DStringAppendElement (&cmd
, filename
);
3009 Tcl_DStringAppendElement (&cmd
, bpdisp
[b
->disposition
]);
3010 sprintf (buf
, "%d", b
->enable
);
3011 Tcl_DStringAppendElement (&cmd
, buf
);
3012 sprintf (buf
, "%d", b
->thread
);
3013 Tcl_DStringAppendElement (&cmd
, buf
);
3015 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
3016 Tcl_DStringFree (&cmd
);
3020 /* This implements the tcl command "gdb_find_bp_at_line"
3023 * filename: the file in which to find the breakpoint
3024 * line: the line number for the breakpoint
3026 * It returns a list of breakpoint numbers
3030 gdb_find_bp_at_line(clientData
, interp
, objc
, objv
)
3031 ClientData clientData
;
3034 Tcl_Obj
*CONST objv
[];
3039 struct breakpoint
*b
;
3040 extern struct breakpoint
*breakpoint_chain
;
3044 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line");
3048 s
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
3052 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
3054 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3058 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3059 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3060 if (b
->line_number
== line
&& !strcmp(b
->source_file
, s
->filename
))
3061 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3062 Tcl_NewIntObj (b
->number
));
3068 /* This implements the tcl command "gdb_find_bp_at_addr"
3073 * It returns a list of breakpoint numbers
3077 gdb_find_bp_at_addr(clientData
, interp
, objc
, objv
)
3078 ClientData clientData
;
3081 Tcl_Obj
*CONST objv
[];
3085 struct breakpoint
*b
;
3086 extern struct breakpoint
*breakpoint_chain
;
3090 Tcl_WrongNumArgs(interp
, 1, objv
, "address");
3094 if (Tcl_GetLongFromObj( interp
, objv
[1], &addr
) == TCL_ERROR
)
3096 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3100 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3101 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3102 if (b
->address
== (CORE_ADDR
)addr
)
3103 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3104 Tcl_NewIntObj (b
->number
));
3109 /* This implements the tcl command gdb_get_breakpoint_info
3115 * A list with {file, function, line_number, address, type, enabled?,
3116 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
3120 gdb_get_breakpoint_info (clientData
, interp
, objc
, objv
)
3121 ClientData clientData
;
3124 Tcl_Obj
*CONST objv
[];
3126 struct symtab_and_line sal
;
3127 struct command_line
*cmd
;
3129 struct breakpoint
*b
;
3130 extern struct breakpoint
*breakpoint_chain
;
3131 char *funcname
, *fname
, *filename
;
3136 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong number of args, should be \"breakpoint\"", -1);
3140 if ( Tcl_GetIntFromObj(NULL
, objv
[1], &bpnum
) != TCL_OK
)
3142 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3146 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3147 if (b
->number
== bpnum
)
3150 if (!b
|| b
->type
!= bp_breakpoint
)
3153 sprintf(err_buf
, "Breakpoint #%d does not exist.", bpnum
);
3154 Tcl_SetStringObj (result_ptr
->obj_ptr
, err_buf
, -1);
3158 sal
= find_pc_line (b
->address
, 0);
3160 filename
= symtab_to_filename (sal
.symtab
);
3161 if (filename
== NULL
)
3164 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3165 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3166 Tcl_NewStringObj (filename
, -1));
3168 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
3169 fname
= cplus_demangle (funcname
, 0);
3172 new_obj
= Tcl_NewStringObj (fname
, -1);
3176 new_obj
= Tcl_NewStringObj (funcname
, -1);
3178 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
3180 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->line_number
));
3181 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%lx", b
->address
);
3182 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3183 Tcl_NewStringObj (bptypes
[b
->type
], -1));
3184 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewBooleanObj(b
->enable
== enabled
));
3185 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3186 Tcl_NewStringObj (bpdisp
[b
->disposition
], -1));
3187 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->ignore_count
));
3189 new_obj
= Tcl_NewObj();
3190 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
3191 Tcl_ListObjAppendElement (NULL
, new_obj
,
3192 Tcl_NewStringObj (cmd
->line
, -1));
3193 Tcl_ListObjAppendElement(NULL
, result_ptr
->obj_ptr
, new_obj
);
3195 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3196 Tcl_NewStringObj (b
->cond_string
, -1));
3198 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->thread
));
3199 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->hit_count
));
3205 /* This implements the tcl command gdb_get_breakpoint_list
3206 * It builds up a list of the current breakpoints.
3211 * A list of breakpoint numbers.
3215 gdb_get_breakpoint_list (clientData
, interp
, objc
, objv
)
3216 ClientData clientData
;
3219 Tcl_Obj
*CONST objv
[];
3221 struct breakpoint
*b
;
3222 extern struct breakpoint
*breakpoint_chain
;
3226 error ("wrong number of args, none are allowed");
3228 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3229 if (b
->type
== bp_breakpoint
)
3231 new_obj
= Tcl_NewIntObj (b
->number
);
3232 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
3238 /* The functions in this section deal with stacks and backtraces. */
3240 /* This implements the tcl command gdb_stack.
3241 * It builds up a list of stack frames.
3244 * start - starting stack frame
3245 * count - number of frames to inspect
3247 * A list of function names
3251 gdb_stack (clientData
, interp
, objc
, objv
) ClientData clientData
;
3254 Tcl_Obj
*CONST objv
[];
3260 Tcl_WrongNumArgs (interp
, 1, objv
, "start count");
3261 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3265 if (Tcl_GetIntFromObj (NULL
, objv
[1], &start
))
3267 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3270 if (Tcl_GetIntFromObj (NULL
, objv
[2], &count
))
3272 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3276 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
3278 if (target_has_stack
)
3280 struct frame_info
*top
;
3281 struct frame_info
*fi
;
3283 /* Find the outermost frame */
3284 fi
= get_current_frame ();
3288 fi
= get_prev_frame (fi
);
3291 /* top now points to the top (outermost frame) of the
3292 stack, so point it to the requested start */
3294 top
= find_relative_frame (top
, &start
);
3296 /* If start != 0, then we have asked to start outputting
3297 frames beyond the innermost stack frame */
3301 while (fi
&& count
--)
3303 get_frame_name (interp
, result_ptr
->obj_ptr
, fi
);
3304 fi
= get_next_frame (fi
);
3312 /* A helper function for get_stack which adds information about
3313 * the stack frame FI to the caller's LIST.
3315 * This is stolen from print_frame_info in stack.c.
3318 get_frame_name (interp
, list
, fi
)
3321 struct frame_info
*fi
;
3323 struct symtab_and_line sal
;
3324 struct symbol
*func
= NULL
;
3325 register char *funname
= 0;
3326 enum language funlang
= language_unknown
;
3329 if (frame_in_dummy (fi
))
3331 objv
[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
3332 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3335 if (fi
->signal_handler_caller
)
3337 objv
[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
3338 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3343 find_pc_line (fi
->pc
,
3345 && !fi
->next
->signal_handler_caller
3346 && !frame_in_dummy (fi
->next
));
3348 func
= find_pc_function (fi
->pc
);
3351 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3353 && (SYMBOL_VALUE_ADDRESS (msymbol
)
3354 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
3357 funname
= SYMBOL_NAME (msymbol
);
3358 funlang
= SYMBOL_LANGUAGE (msymbol
);
3362 funname
= SYMBOL_NAME (func
);
3363 funlang
= SYMBOL_LANGUAGE (func
);
3368 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3369 if (msymbol
!= NULL
)
3371 funname
= SYMBOL_NAME (msymbol
);
3372 funlang
= SYMBOL_LANGUAGE (msymbol
);
3380 if (funlang
== language_cplus
)
3381 name
= cplus_demangle (funname
, 0);
3385 objv
[0] = Tcl_NewStringObj (name
, -1);
3386 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3391 /* we have no convenient way to deal with this yet... */
3392 if (fi
->pc
!= sal
.pc
|| !sal
.symtab
)
3394 print_address_numeric (fi
->pc
, 1, gdb_stdout
);
3395 printf_filtered (" in ");
3397 printf_symbol_filtered (gdb_stdout
, funname
? funname
: "??", funlang
,
3400 objv
[0] = Tcl_NewStringObj (funname
!= NULL
? funname
: "??", -1);
3401 #ifdef PC_LOAD_SEGMENT
3402 /* If we couldn't print out function name but if can figure out what
3403 load segment this pc value is from, at least print out some info
3404 about its load segment. */
3407 Tcl_AppendStringsToObj (objv
[0], " from ", PC_LOAD_SEGMENT (fi
->pc
),
3414 char *lib
= PC_SOLIB (fi
->pc
);
3417 Tcl_AppendStringsToObj (objv
[0], " from ", lib
, (char *) NULL
);
3421 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3427 * This section contains a bunch of miscellaneous utility commands
3430 /* This implements the tcl command gdb_path_conv
3432 * On Windows, it canonicalizes the pathname,
3433 * On Unix, it is a no op.
3438 * The canonicalized path.
3442 gdb_path_conv (clientData
, interp
, objc
, objv
)
3443 ClientData clientData
;
3446 Tcl_Obj
*CONST objv
[];
3449 error ("wrong # args");
3453 char pathname
[256], *ptr
;
3455 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj (objv
[1], NULL
), pathname
);
3456 for (ptr
= pathname
; *ptr
; ptr
++)
3461 Tcl_SetStringObj (result_ptr
->obj_ptr
, pathname
, -1);
3464 Tcl_SetStringObj (result_ptr
->obj_ptr
, Tcl_GetStringFromObj (objv
[1], NULL
), -1);
3471 * This section has utility routines that are not Tcl commands.
3475 perror_with_name_wrapper (args
)
3478 perror_with_name (args
);
3482 /* The lookup_symtab() in symtab.c doesn't work correctly */
3483 /* It will not work will full pathnames and if multiple */
3484 /* source files have the same basename, it will return */
3485 /* the first one instead of the correct one. This version */
3486 /* also always makes sure symtab->fullname is set. */
3488 static struct symtab
*
3489 full_lookup_symtab(file
)
3493 struct objfile
*objfile
;
3494 char *bfile
, *fullname
;
3495 struct partial_symtab
*pt
;
3500 /* first try a direct lookup */
3501 st
= lookup_symtab (file
);
3505 symtab_to_filename(st
);
3509 /* if the direct approach failed, try */
3510 /* looking up the basename and checking */
3511 /* all matches with the fullname */
3512 bfile
= basename (file
);
3513 ALL_SYMTABS (objfile
, st
)
3515 if (!strcmp (bfile
, basename(st
->filename
)))
3518 fullname
= symtab_to_filename (st
);
3520 fullname
= st
->fullname
;
3522 if (!strcmp (file
, fullname
))
3527 /* still no luck? look at psymtabs */
3528 ALL_PSYMTABS (objfile
, pt
)
3530 if (!strcmp (bfile
, basename(pt
->filename
)))
3532 st
= PSYMTAB_TO_SYMTAB (pt
);
3535 fullname
= symtab_to_filename (st
);
3536 if (!strcmp (file
, fullname
))