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
;
157 * Declarations for routines exported from this file
160 int Gdbtk_Init (Tcl_Interp
*interp
);
163 * Declarations for routines used only in this file.
166 static int compare_lines
PARAMS ((const PTR
, const PTR
));
167 static int comp_files
PARAMS ((const void *, const void *));
168 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
169 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
170 Tcl_Obj
*CONST objv
[]));
171 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
172 static int gdb_clear_file
PARAMS ((ClientData
, Tcl_Interp
*interp
, int, Tcl_Obj
*CONST
[]));
173 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
174 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
175 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int,
177 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
178 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
179 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
180 Tcl_Obj
*CONST objv
[]));
181 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
182 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
183 static int gdb_get_args_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
184 Tcl_Obj
*CONST objv
[]));
185 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
186 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
187 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
188 Tcl_Obj
*CONST objv
[]));
189 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
190 Tcl_Obj
*CONST objv
[]));
191 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
192 Tcl_Obj
*CONST objv
[]));
193 static int gdb_get_locals_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
194 Tcl_Obj
*CONST objv
[]));
195 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
196 static int gdb_get_trace_frame_num
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
197 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int,
198 Tcl_Obj
*CONST objv
[]));
199 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
200 Tcl_Obj
*CONST objv
[]));
201 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
202 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
203 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
204 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
205 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
206 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
207 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
208 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
209 Tcl_Obj
*CONST objv
[]));
210 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
211 static int gdb_search
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
213 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
214 static int gdb_set_bp_addr
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
215 static int gdb_find_bp_at_line
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
216 static int gdb_find_bp_at_addr
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
217 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
218 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*,
221 static int gdb_trace_status
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
222 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*,
224 Tcl_Obj
*CONST objv
[]));
225 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int,
226 Tcl_Obj
*CONST objv
[]));
227 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
228 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
229 static int gdb_stack
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
231 char * get_prompt
PARAMS ((void));
232 static void get_register
PARAMS ((int, void *));
233 static void get_register_name
PARAMS ((int, void *));
234 static int map_arg_registers
PARAMS ((int, Tcl_Obj
*CONST
[], void (*) (int, void *), void *));
235 static int perror_with_name_wrapper
PARAMS ((char *args
));
236 static void register_changed_p
PARAMS ((int, void *));
237 void TclDebug
PARAMS ((const char *fmt
, ...));
238 static int wrapped_call (char *opaque_args
);
239 static void get_frame_name
PARAMS ((Tcl_Interp
*interp
, Tcl_Obj
*list
, struct frame_info
*fi
));
242 * This loads all the Tcl commands into the Tcl interpreter.
245 * interp - The interpreter into which to load the commands.
248 * A standard Tcl result.
255 Tcl_CreateObjCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
256 Tcl_CreateObjCommand (interp
, "gdb_immediate", call_wrapper
,
257 gdb_immediate_command
, NULL
);
258 Tcl_CreateObjCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
259 Tcl_CreateObjCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
260 Tcl_CreateObjCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
, NULL
);
261 Tcl_CreateObjCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
263 Tcl_CreateObjCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
265 Tcl_CreateObjCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
266 Tcl_CreateObjCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
267 Tcl_CreateObjCommand (interp
, "gdb_fetch_registers", call_wrapper
,
268 gdb_fetch_registers
, NULL
);
269 Tcl_CreateObjCommand (interp
, "gdb_changed_register_list", call_wrapper
,
270 gdb_changed_register_list
, NULL
);
271 Tcl_CreateObjCommand (interp
, "gdb_disassemble", call_wrapper
,
272 gdb_disassemble
, NULL
);
273 Tcl_CreateObjCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
274 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
275 gdb_get_breakpoint_list
, NULL
);
276 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
277 gdb_get_breakpoint_info
, NULL
);
278 Tcl_CreateObjCommand (interp
, "gdb_clear_file", call_wrapper
,
279 gdb_clear_file
, NULL
);
280 Tcl_CreateObjCommand (interp
, "gdb_confirm_quit", call_wrapper
,
281 gdb_confirm_quit
, NULL
);
282 Tcl_CreateObjCommand (interp
, "gdb_force_quit", call_wrapper
,
283 gdb_force_quit
, NULL
);
284 Tcl_CreateObjCommand (interp
, "gdb_target_has_execution",
286 gdb_target_has_execution_command
, NULL
);
287 Tcl_CreateObjCommand (interp
, "gdb_is_tracing",
288 call_wrapper
, gdb_trace_status
,
290 Tcl_CreateObjCommand (interp
, "gdb_load_info", call_wrapper
, gdb_load_info
, NULL
);
291 Tcl_CreateObjCommand (interp
, "gdb_get_locals", call_wrapper
, gdb_get_locals_command
,
293 Tcl_CreateObjCommand (interp
, "gdb_get_args", call_wrapper
, gdb_get_args_command
,
295 Tcl_CreateObjCommand (interp
, "gdb_get_function", call_wrapper
, gdb_get_function_command
,
297 Tcl_CreateObjCommand (interp
, "gdb_get_line", call_wrapper
, gdb_get_line_command
,
299 Tcl_CreateObjCommand (interp
, "gdb_get_file", call_wrapper
, gdb_get_file_command
,
301 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
302 call_wrapper
, gdb_tracepoint_exists_command
, NULL
);
303 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
304 call_wrapper
, gdb_get_tracepoint_info
, NULL
);
305 Tcl_CreateObjCommand (interp
, "gdb_actions",
306 call_wrapper
, gdb_actions_command
, NULL
);
307 Tcl_CreateObjCommand (interp
, "gdb_prompt",
308 call_wrapper
, gdb_prompt_command
, NULL
);
309 Tcl_CreateObjCommand (interp
, "gdb_find_file",
310 call_wrapper
, gdb_find_file_command
, NULL
);
311 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
312 call_wrapper
, gdb_get_tracepoint_list
, NULL
);
313 Tcl_CreateObjCommand (interp
, "gdb_pc_reg", call_wrapper
, get_pc_register
, NULL
);
314 Tcl_CreateObjCommand (interp
, "gdb_loadfile", call_wrapper
, gdb_loadfile
, NULL
);
315 Tcl_CreateObjCommand (gdbtk_interp
, "gdb_search", call_wrapper
,
317 Tcl_CreateObjCommand (interp
, "gdb_set_bp", call_wrapper
, gdb_set_bp
, NULL
);
318 Tcl_CreateObjCommand (interp
, "gdb_set_bp_addr", call_wrapper
, gdb_set_bp_addr
, NULL
);
319 Tcl_CreateObjCommand (interp
, "gdb_find_bp_at_line", call_wrapper
, gdb_find_bp_at_line
, NULL
);
320 Tcl_CreateObjCommand (interp
, "gdb_find_bp_at_addr", call_wrapper
, gdb_find_bp_at_addr
, NULL
);
321 Tcl_CreateObjCommand (interp
, "gdb_get_trace_frame_num",
322 call_wrapper
, gdb_get_trace_frame_num
, NULL
);
323 Tcl_CreateObjCommand (interp
, "gdb_stack", call_wrapper
, gdb_stack
, NULL
);
325 Tcl_LinkVar (interp
, "gdb_selected_frame_level",
326 (char *) &selected_frame_level
,
327 TCL_LINK_INT
| TCL_LINK_READ_ONLY
);
329 /* gdb_context is used for debugging multiple threads or tasks */
330 Tcl_LinkVar (interp
, "gdb_context_id",
331 (char *) &gdb_context
,
332 TCL_LINK_INT
| TCL_LINK_READ_ONLY
);
334 Tcl_PkgProvide(interp
, "Gdbtk", GDBTK_VERSION
);
338 /* This routine acts as a top-level for all GDB code called by Tcl/Tk. It
339 handles cleanups, and uses catch_errors to trap calls to return_to_top_level
341 This is necessary in order to prevent a longjmp out of the bowels of Tk,
342 possibly leaving things in a bad state. Since this routine can be called
343 recursively, it needs to save and restore the contents of the result_ptr as
347 call_wrapper (clientData
, interp
, objc
, objv
)
348 ClientData clientData
;
351 Tcl_Obj
*CONST objv
[];
353 struct wrapped_call_args wrapped_args
;
354 gdbtk_result new_result
, *old_result_ptr
;
356 old_result_ptr
= result_ptr
;
357 result_ptr
= &new_result
;
358 result_ptr
->obj_ptr
= Tcl_NewObj();
359 result_ptr
->flags
= GDBTK_TO_RESULT
;
361 wrapped_args
.func
= (Tcl_ObjCmdProc
*) clientData
;
362 wrapped_args
.interp
= interp
;
363 wrapped_args
.objc
= objc
;
364 wrapped_args
.objv
= objv
;
365 wrapped_args
.val
= TCL_OK
;
367 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
370 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
372 /* Make sure the timer interrupts are turned off. */
376 gdb_flush (gdb_stderr
); /* Flush error output */
377 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
379 /* If we errored out here, and the results were going to the
380 console, then gdbtk_fputs will have gathered the result into the
381 result_ptr. We also need to echo them out to the console here */
383 gdb_flush (gdb_stderr
); /* Flush error output */
384 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
386 /* In case of an error, we may need to force the GUI into idle
387 mode because gdbtk_call_command may have bombed out while in
388 the command routine. */
391 Tcl_Eval (interp
, "gdbtk_tcl_idle");
395 /* do not suppress any errors -- a remote target could have errored */
396 load_in_progress
= 0;
399 * Now copy the result over to the true Tcl result. If GDBTK_TO_RESULT flag
400 * bit is set , this just copies a null object over to the Tcl result, which is
401 * fine because we should reset the result in this case anyway.
403 if (result_ptr
->flags
& GDBTK_IN_TCL_RESULT
)
405 Tcl_DecrRefCount(result_ptr
->obj_ptr
);
409 Tcl_SetObjResult (interp
, result_ptr
->obj_ptr
);
412 result_ptr
= old_result_ptr
;
418 return wrapped_args
.val
;
422 * This is the wrapper that is passed to catch_errors.
426 wrapped_call (opaque_args
)
429 struct wrapped_call_args
*args
= (struct wrapped_call_args
*) opaque_args
;
430 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->objc
, args
->objv
);
434 /* This is a convenience function to sprintf something(s) into a
435 * new element in a Tcl list object.
439 #ifdef ANSI_PROTOTYPES
440 sprintf_append_element_to_obj (Tcl_Obj
*objp
, char *format
, ...)
442 sprintf_append_element_to_obj (va_alist
)
449 #ifdef ANSI_PROTOTYPES
450 va_start (args
, format
);
456 dsp
= va_arg (args
, Tcl_Obj
*);
457 format
= va_arg (args
, char *);
460 vsprintf (buf
, format
, args
);
462 Tcl_ListObjAppendElement (NULL
, objp
, Tcl_NewStringObj (buf
, -1));
466 * This section contains the commands that control execution.
469 /* This implements the tcl command gdb_clear_file.
471 * Prepare to accept a new executable file. This is called when we
472 * want to clear away everything we know about the old file, without
473 * asking the user. The Tcl code will have already asked the user if
474 * necessary. After this is called, we should be able to run the
475 * `file' command without getting any questions.
484 gdb_clear_file (clientData
, interp
, objc
, objv
)
485 ClientData clientData
;
488 Tcl_Obj
*CONST objv
[];
491 Tcl_SetStringObj (result_ptr
->obj_ptr
,
492 "Wrong number of args, none are allowed.", -1);
494 if (inferior_pid
!= 0 && target_has_execution
)
497 target_detach (NULL
, 0);
502 if (target_has_execution
)
505 symbol_file_command (NULL
, 0);
507 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
508 clear it here. FIXME: This seems like an abstraction violation
515 /* This implements the tcl command gdb_confirm_quit
516 * Ask the user to confirm an exit request.
521 * A boolean, 1 if the user answered yes, 0 if no.
525 gdb_confirm_quit (clientData
, interp
, objc
, objv
)
526 ClientData clientData
;
529 Tcl_Obj
*CONST objv
[];
535 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
539 ret
= quit_confirm ();
540 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, ret
);
544 /* This implements the tcl command gdb_force_quit
545 * Quit without asking for confirmation.
554 gdb_force_quit (clientData
, interp
, objc
, objv
)
555 ClientData clientData
;
558 Tcl_Obj
*CONST objv
[];
562 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
566 quit_force ((char *) NULL
, 1);
570 /* This implements the tcl command gdb_stop
571 * It stops the target in a continuable fashion.
580 gdb_stop (clientData
, interp
, objc
, objv
)
581 ClientData clientData
;
584 Tcl_Obj
*CONST objv
[];
586 if (target_stop
!= target_ignore
)
589 quit_flag
= 1; /* hope something sees this */
596 * This section contains Tcl commands that are wrappers for invoking
597 * the GDB command interpreter.
601 /* This implements the tcl command `gdb_eval'.
602 * It uses the gdb evaluator to return the value of
603 * an expression in the current language
606 * expression - the expression to evaluate.
608 * The result of the evaluation.
612 gdb_eval (clientData
, interp
, objc
, objv
)
613 ClientData clientData
;
616 Tcl_Obj
*CONST objv
[];
618 struct expression
*expr
;
619 struct cleanup
*old_chain
=NULL
;
624 Tcl_SetStringObj (result_ptr
->obj_ptr
,
625 "wrong # args, should be \"gdb_eval expression\"", -1);
629 expr
= parse_expression (Tcl_GetStringFromObj (objv
[1], NULL
));
631 old_chain
= make_cleanup ((make_cleanup_func
) free_current_contents
, &expr
);
633 val
= evaluate_expression (expr
);
636 * Print the result of the expression evaluation. This will go to
637 * eventually go to gdbtk_fputs, and from there be collected into
641 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
642 gdb_stdout
, 0, 0, 0, 0);
644 do_cleanups (old_chain
);
649 /* This implements the tcl command "gdb_cmd".
651 * It sends its argument to the GDB command scanner for execution.
652 * This command will never cause the update, idle and busy hooks to be called
656 * command - The GDB command to execute
658 * The output from the gdb command (except for the "load" & "while"
659 * which dump their output to the console.
663 gdb_cmd (clientData
, interp
, objc
, objv
)
664 ClientData clientData
;
667 Tcl_Obj
*CONST objv
[];
672 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
676 if (running_now
|| load_in_progress
)
681 /* for the load instruction (and possibly others later) we
682 set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
683 will not buffer all the data until the command is finished. */
685 if ((strncmp ("load ", Tcl_GetStringFromObj (objv
[1], NULL
), 5) == 0))
687 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
688 load_in_progress
= 1;
691 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
693 if (load_in_progress
)
695 load_in_progress
= 0;
696 result_ptr
->flags
|= GDBTK_TO_RESULT
;
699 bpstat_do_actions (&stop_bpstat
);
705 * This implements the tcl command "gdb_immediate"
707 * It does exactly the same thing as gdb_cmd, except NONE of its outut
708 * is buffered. This will also ALWAYS cause the busy, update, and idle hooks to
709 * be called, contrasted with gdb_cmd, which NEVER calls them.
710 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
711 * to the console window.
714 * command - The GDB command to execute
720 gdb_immediate_command (clientData
, interp
, objc
, objv
)
721 ClientData clientData
;
724 Tcl_Obj
*CONST objv
[];
729 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
733 if (running_now
|| load_in_progress
)
738 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
740 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
742 bpstat_do_actions (&stop_bpstat
);
744 result_ptr
->flags
|= GDBTK_TO_RESULT
;
749 /* This implements the tcl command "gdb_prompt"
751 * It returns the gdb interpreter's prompt.
760 gdb_prompt_command (clientData
, interp
, objc
, objv
)
761 ClientData clientData
;
764 Tcl_Obj
*CONST objv
[];
766 Tcl_SetStringObj (result_ptr
->obj_ptr
, get_prompt (), -1);
772 * This section contains general informational commands.
775 /* This implements the tcl command "gdb_target_has_execution"
777 * Tells whether the target is executing.
782 * A boolean indicating whether the target is executing.
786 gdb_target_has_execution_command (clientData
, interp
, objc
, objv
)
787 ClientData clientData
;
790 Tcl_Obj
*CONST objv
[];
794 if (target_has_execution
&& inferior_pid
!= 0)
797 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, result
);
801 /* This implements the tcl command "gdb_load_info"
803 * It returns information about the file about to be downloaded.
806 * filename: The file to open & get the info on.
808 * A list consisting of the name and size of each section.
812 gdb_load_info (clientData
, interp
, objc
, objv
)
813 ClientData clientData
;
816 Tcl_Obj
*CONST objv
[];
819 struct cleanup
*old_cleanups
;
823 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
825 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
826 if (loadfile_bfd
== NULL
)
828 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Open failed", -1);
831 old_cleanups
= make_cleanup ((make_cleanup_func
) bfd_close
, loadfile_bfd
);
833 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
835 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Bad Object File", -1);
839 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
841 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
843 if (s
->flags
& SEC_LOAD
)
845 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
848 ob
[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd
, s
), -1);
849 ob
[1] = Tcl_NewLongObj ((long) size
);
850 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewListObj (2, ob
));
855 do_cleanups (old_cleanups
);
861 * This and gdb_get_locals just call gdb_get_vars_command with the right
862 * value of clientData. We can't use the client data in the definition
863 * of the command, because the call wrapper uses this instead...
867 gdb_get_locals_command (clientData
, interp
, objc
, objv
)
868 ClientData clientData
;
871 Tcl_Obj
*CONST objv
[];
874 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
879 gdb_get_args_command (clientData
, interp
, objc
, objv
)
880 ClientData clientData
;
883 Tcl_Obj
*CONST objv
[];
886 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
890 /* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
892 * This function sets the Tcl interpreter's result to a list of variable names
893 * depending on clientData. If clientData is one, the result is a list of
894 * arguments; zero returns a list of locals -- all relative to the block
895 * specified as an argument to the command. Valid commands include
896 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
900 * block - the address within which to specify the locals or args.
902 * A list of the locals or args
906 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
907 ClientData clientData
;
910 Tcl_Obj
*CONST objv
[];
912 struct symtabs_and_lines sals
;
915 char **canonical
, *args
;
916 int i
, nsyms
, arguments
;
920 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
,
921 "wrong # of args: should be \"",
922 Tcl_GetStringFromObj (objv
[0], NULL
),
923 " function:line|function|line|*addr\"", NULL
);
927 arguments
= (int) clientData
;
928 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
929 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
932 Tcl_SetStringObj (result_ptr
->obj_ptr
,
933 "error decoding line", -1);
937 /* Initialize the result pointer to an empty list. */
939 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
941 /* Resolve all line numbers to PC's */
942 for (i
= 0; i
< sals
.nelts
; i
++)
943 resolve_sal_pc (&sals
.sals
[i
]);
945 block
= block_for_pc (sals
.sals
[0].pc
);
948 nsyms
= BLOCK_NSYMS (block
);
949 for (i
= 0; i
< nsyms
; i
++)
951 sym
= BLOCK_SYM (block
, i
);
952 switch (SYMBOL_CLASS (sym
)) {
954 case LOC_UNDEF
: /* catches errors */
955 case LOC_CONST
: /* constant */
956 case LOC_TYPEDEF
: /* local typedef */
957 case LOC_LABEL
: /* local label */
958 case LOC_BLOCK
: /* local function */
959 case LOC_CONST_BYTES
: /* loc. byte seq. */
960 case LOC_UNRESOLVED
: /* unresolved static */
961 case LOC_OPTIMIZED_OUT
: /* optimized out */
963 case LOC_ARG
: /* argument */
964 case LOC_REF_ARG
: /* reference arg */
965 case LOC_REGPARM
: /* register arg */
966 case LOC_REGPARM_ADDR
: /* indirect register arg */
967 case LOC_LOCAL_ARG
: /* stack arg */
968 case LOC_BASEREG_ARG
: /* basereg arg */
970 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
971 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
973 case LOC_LOCAL
: /* stack local */
974 case LOC_BASEREG
: /* basereg local */
975 case LOC_STATIC
: /* static */
976 case LOC_REGISTER
: /* register */
978 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
979 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
983 if (BLOCK_FUNCTION (block
))
986 block
= BLOCK_SUPERBLOCK (block
);
992 /* This implements the tcl command "gdb_get_line"
994 * It returns the linenumber for a given linespec. It will take any spec
995 * that can be passed to decode_line_1
998 * linespec - the line specification
1000 * The line number for that spec.
1003 gdb_get_line_command (clientData
, interp
, objc
, objv
)
1004 ClientData clientData
;
1007 Tcl_Obj
*CONST objv
[];
1009 struct symtabs_and_lines sals
;
1010 char *args
, **canonical
;
1014 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1015 Tcl_GetStringFromObj (objv
[0], NULL
),
1016 " linespec\"", NULL
);
1020 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1021 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1022 if (sals
.nelts
== 1)
1024 Tcl_SetIntObj (result_ptr
->obj_ptr
, sals
.sals
[0].line
);
1028 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1033 /* This implements the tcl command "gdb_get_file"
1035 * It returns the file containing a given line spec.
1038 * linespec - The linespec to look up
1040 * The file containing it.
1044 gdb_get_file_command (clientData
, interp
, objc
, objv
)
1045 ClientData clientData
;
1048 Tcl_Obj
*CONST objv
[];
1050 struct symtabs_and_lines sals
;
1051 char *args
, **canonical
;
1055 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1056 Tcl_GetStringFromObj (objv
[0], NULL
),
1057 " linespec\"", NULL
);
1061 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1062 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1063 if (sals
.nelts
== 1)
1065 Tcl_SetStringObj (result_ptr
->obj_ptr
, sals
.sals
[0].symtab
->filename
, -1);
1069 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1073 /* This implements the tcl command "gdb_get_function"
1075 * It finds the function containing the given line spec.
1078 * linespec - The line specification
1080 * The function that contains it, or "N/A" if it is not in a function.
1083 gdb_get_function_command (clientData
, interp
, objc
, objv
)
1084 ClientData clientData
;
1087 Tcl_Obj
*CONST objv
[];
1090 struct symtabs_and_lines sals
;
1091 char *args
, **canonical
;
1095 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1096 Tcl_GetStringFromObj (objv
[0], NULL
),
1097 " linespec\"", NULL
);
1101 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1102 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1103 if (sals
.nelts
== 1)
1105 resolve_sal_pc (&sals
.sals
[0]);
1106 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
1107 if (function
!= NULL
)
1109 Tcl_SetStringObj (result_ptr
->obj_ptr
, function
, -1);
1114 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1118 /* This implements the tcl command "gdb_find_file"
1120 * It searches the symbol tables to get the full pathname to a file.
1123 * filename: the file name to search for.
1125 * The full path to the file, or an empty string if the file is not
1130 gdb_find_file_command (clientData
, interp
, objc
, objv
)
1131 ClientData clientData
;
1134 Tcl_Obj
*CONST objv
[];
1136 char *filename
= NULL
;
1141 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
1145 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1147 filename
= st
->fullname
;
1149 if (filename
== NULL
)
1150 Tcl_SetStringObj (result_ptr
->obj_ptr
, "", 0);
1152 Tcl_SetStringObj (result_ptr
->obj_ptr
, filename
, -1);
1157 /* This implements the tcl command "gdb_listfiles"
1159 * This lists all the files in the current executible.
1161 * Note that this currently pulls in all sorts of filenames
1162 * that aren't really part of the executable. It would be
1163 * best if we could check each file to see if it actually
1164 * contains executable lines of code, but we can't do that
1168 * ?pathname? - If provided, only files which match pathname
1169 * (up to strlen(pathname)) are included. THIS DOES NOT
1170 * CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1171 * THE FULL PATHNAME!!!
1174 * A list of all matching files.
1177 gdb_listfiles (clientData
, interp
, objc
, objv
)
1178 ClientData clientData
;
1181 Tcl_Obj
*CONST objv
[];
1183 struct objfile
*objfile
;
1184 struct partial_symtab
*psymtab
;
1185 struct symtab
*symtab
;
1186 char *lastfile
, *pathname
=NULL
, **files
;
1188 int i
, numfiles
= 0, len
= 0;
1191 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1195 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1199 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1201 ALL_PSYMTABS (objfile
, psymtab
)
1203 if (numfiles
== files_size
)
1205 files_size
= files_size
* 2;
1206 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1208 if (psymtab
->filename
)
1210 if (!len
|| !strncmp(pathname
, psymtab
->filename
,len
)
1211 || !strcmp(psymtab
->filename
, basename(psymtab
->filename
)))
1213 files
[numfiles
++] = basename(psymtab
->filename
);
1218 ALL_SYMTABS (objfile
, symtab
)
1220 if (numfiles
== files_size
)
1222 files_size
= files_size
* 2;
1223 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1225 if (symtab
->filename
&& symtab
->linetable
&& symtab
->linetable
->nitems
)
1227 if (!len
|| !strncmp(pathname
, symtab
->filename
,len
)
1228 || !strcmp(symtab
->filename
, basename(symtab
->filename
)))
1230 files
[numfiles
++] = basename(symtab
->filename
);
1235 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1239 /* Discard the old result pointer, in case it has accumulated anything
1240 and set it to a new list object */
1242 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1244 for (i
= 0; i
< numfiles
; i
++)
1246 if (strcmp(files
[i
],lastfile
))
1247 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj(files
[i
], -1));
1248 lastfile
= files
[i
];
1256 comp_files (file1
, file2
)
1257 const void *file1
, *file2
;
1259 return strcmp(* (char **) file1
, * (char **) file2
);
1263 /* This implements the tcl command "gdb_search"
1267 * option - One of "functions", "variables" or "types"
1268 * regexp - The regular expression to look for.
1277 gdb_search (clientData
, interp
, objc
, objv
)
1278 ClientData clientData
;
1281 Tcl_Obj
*CONST objv
[];
1283 struct symbol_search
*ss
= NULL
;
1284 struct symbol_search
*p
;
1285 struct cleanup
*old_chain
= NULL
;
1286 Tcl_Obj
*CONST
*switch_objv
;
1287 int index
, switch_objc
, i
;
1288 namespace_enum space
= 0;
1290 int static_only
, nfiles
;
1291 Tcl_Obj
**file_list
;
1293 static char *search_options
[] = { "functions", "variables", "types", (char *) NULL
};
1294 static char *switches
[] = { "-files", "-static", (char *) NULL
};
1295 enum search_opts
{ SEARCH_FUNCTIONS
, SEARCH_VARIABLES
, SEARCH_TYPES
};
1296 enum switches_opts
{ SWITCH_FILES
, SWITCH_STATIC_ONLY
};
1300 Tcl_WrongNumArgs (interp
, 1, objv
, "option regexp ?arg ...?");
1301 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1305 if (Tcl_GetIndexFromObj (interp
, objv
[1], search_options
, "option", 0,
1308 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1312 /* Unfortunately, we cannot teach search_symbols to search on
1313 multiple regexps, so we have to do a two-tier search for
1314 any searches which choose to narrow the playing field. */
1315 switch ((enum search_opts
) index
)
1317 case SEARCH_FUNCTIONS
:
1318 space
= FUNCTIONS_NAMESPACE
; break;
1319 case SEARCH_VARIABLES
:
1320 space
= VARIABLES_NAMESPACE
; break;
1322 space
= TYPES_NAMESPACE
; break;
1325 regexp
= Tcl_GetStringFromObj (objv
[2], NULL
);
1326 /* Process any switches that refine the search */
1327 switch_objc
= objc
- 3;
1328 switch_objv
= objv
+ 3;
1332 files
= (char **) NULL
;
1333 while (switch_objc
> 0)
1335 if (Tcl_GetIndexFromObj (interp
, switch_objv
[0], switches
,
1336 "option", 0, &index
) != TCL_OK
)
1338 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1342 switch ((enum switches_opts
) index
)
1347 if (switch_objc
< 2)
1349 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList -static 1|0]");
1350 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1353 result
= Tcl_ListObjGetElements (interp
, switch_objv
[1], &nfiles
, &file_list
);
1354 if (result
!= TCL_OK
)
1357 files
= (char **) xmalloc (nfiles
* sizeof (char *));
1358 for (i
= 0; i
< nfiles
; i
++)
1359 files
[i
] = Tcl_GetStringFromObj (file_list
[i
], NULL
);
1364 case SWITCH_STATIC_ONLY
:
1365 if (switch_objc
< 2)
1367 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList] [-static 1|0]");
1368 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1371 if ( Tcl_GetBooleanFromObj (interp
, switch_objv
[1], &static_only
) !=
1373 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1383 search_symbols (regexp
, space
, nfiles
, files
, &ss
);
1385 old_chain
= make_cleanup ((make_cleanup_func
) free_search_symbols
, ss
);
1387 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1389 for (p
= ss
; p
!= NULL
; p
= p
->next
)
1393 if (static_only
&& p
->block
!= STATIC_BLOCK
)
1396 elem
= Tcl_NewListObj (0, NULL
);
1398 if (p
->msymbol
== NULL
)
1399 Tcl_ListObjAppendElement (interp
, elem
,
1400 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->symbol
), -1));
1402 Tcl_ListObjAppendElement (interp
, elem
,
1403 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->msymbol
), -1));
1405 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, elem
);
1409 do_cleanups (old_chain
);
1414 /* This implements the tcl command gdb_listfuncs
1416 * It lists all the functions defined in a given file
1419 * file - the file to look in
1421 * A list of two element lists, the first element is
1422 * the symbol name, and the second is a boolean indicating
1423 * whether the symbol is demangled (1 for yes).
1427 gdb_listfuncs (clientData
, interp
, objc
, objv
)
1428 ClientData clientData
;
1431 Tcl_Obj
*CONST objv
[];
1433 struct symtab
*symtab
;
1434 struct blockvector
*bv
;
1438 Tcl_Obj
*funcVals
[2];
1442 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1445 symtab
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1448 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No such file", -1);
1452 if (mangled
== NULL
)
1454 mangled
= Tcl_NewBooleanObj(1);
1455 not_mangled
= Tcl_NewBooleanObj(0);
1456 Tcl_IncrRefCount(mangled
);
1457 Tcl_IncrRefCount(not_mangled
);
1460 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1462 bv
= BLOCKVECTOR (symtab
);
1463 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1465 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1466 /* Skip the sort if this block is always sorted. */
1467 if (!BLOCK_SHOULD_SORT (b
))
1468 sort_block_syms (b
);
1469 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1471 sym
= BLOCK_SYM (b
, j
);
1472 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1475 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1478 /* strip out "global constructors" and "global destructors" */
1479 /* because we aren't interested in them. */
1480 if (strncmp (name
, "global ", 7))
1482 funcVals
[0] = Tcl_NewStringObj(name
, -1);
1483 funcVals
[1] = mangled
;
1491 funcVals
[0] = Tcl_NewStringObj(SYMBOL_NAME(sym
), -1);
1492 funcVals
[1] = not_mangled
;
1494 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1495 Tcl_NewListObj (2, funcVals
));
1504 * This section contains all the commands that act on the registers:
1507 /* This is a sort of mapcar function for operations on registers */
1510 map_arg_registers (objc
, objv
, func
, argp
)
1512 Tcl_Obj
*CONST objv
[];
1513 void (*func
) PARAMS ((int regnum
, void *argp
));
1518 /* Note that the test for a valid register must include checking the
1519 reg_names array because NUM_REGS may be allocated for the union of the
1520 register sets within a family of related processors. In this case, the
1521 trailing entries of reg_names will change depending upon the particular
1522 processor being debugged. */
1524 if (objc
== 0) /* No args, just do all the regs */
1528 && reg_names
[regnum
] != NULL
1529 && *reg_names
[regnum
] != '\000';
1531 func (regnum
, argp
);
1536 /* Else, list of register #s, just do listed regs */
1537 for (; objc
> 0; objc
--, objv
++)
1539 if (Tcl_GetIntFromObj (NULL
, *objv
, ®num
) != TCL_OK
)
1541 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1546 && regnum
< NUM_REGS
1547 && reg_names
[regnum
] != NULL
1548 && *reg_names
[regnum
] != '\000')
1549 func (regnum
, argp
);
1552 Tcl_SetStringObj (result_ptr
->obj_ptr
, "bad register number", -1);
1560 /* This implements the TCL command `gdb_regnames', which returns a list of
1561 all of the register names. */
1564 gdb_regnames (clientData
, interp
, objc
, objv
)
1565 ClientData clientData
;
1568 Tcl_Obj
*CONST objv
[];
1573 return map_arg_registers (objc
, objv
, get_register_name
, NULL
);
1577 get_register_name (regnum
, argp
)
1579 void *argp
; /* Ignored */
1581 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1582 Tcl_NewStringObj (reg_names
[regnum
], -1));
1585 /* This implements the tcl command gdb_fetch_registers
1586 * Pass it a list of register names, and it will
1587 * return their values as a list.
1590 * format: The format string for printing the values
1591 * args: the registers to look for
1593 * A list of their values.
1597 gdb_fetch_registers (clientData
, interp
, objc
, objv
)
1598 ClientData clientData
;
1601 Tcl_Obj
*CONST objv
[];
1607 Tcl_SetStringObj (result_ptr
->obj_ptr
,
1608 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
1612 format
= *(Tcl_GetStringFromObj(objv
[0], NULL
));
1616 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Output the results as a list */
1617 result
= map_arg_registers (objc
, objv
, get_register
, (void *) format
);
1618 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
1624 get_register (regnum
, fp
)
1628 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1629 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
1630 int format
= (int)fp
;
1635 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1637 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1638 Tcl_NewStringObj ("Optimized out", -1));
1642 /* Convert raw data to virtual format if necessary. */
1644 if (REGISTER_CONVERTIBLE (regnum
))
1646 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
1647 raw_buffer
, virtual_buffer
);
1650 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1655 printf_filtered ("0x");
1656 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1658 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1659 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1660 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
1664 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
1665 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1669 /* This implements the tcl command get_pc_reg
1670 * It returns the value of the PC register
1675 * The value of the pc register.
1679 get_pc_register (clientData
, interp
, objc
, objv
)
1680 ClientData clientData
;
1683 Tcl_Obj
*CONST objv
[];
1687 sprintf (buff
, "0x%llx",(long long) read_register (PC_REGNUM
));
1688 Tcl_SetStringObj(result_ptr
->obj_ptr
, buff
, -1);
1692 /* This implements the tcl command "gdb_changed_register_list"
1693 * It takes a list of registers, and returns a list of
1694 * the registers on that list that have changed since the last
1695 * time the proc was called.
1698 * A list of registers.
1700 * A list of changed registers.
1704 gdb_changed_register_list (clientData
, interp
, objc
, objv
)
1705 ClientData clientData
;
1708 Tcl_Obj
*CONST objv
[];
1713 return map_arg_registers (objc
, objv
, register_changed_p
, NULL
);
1717 register_changed_p (regnum
, argp
)
1719 void *argp
; /* Ignored */
1721 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1723 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1726 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1727 REGISTER_RAW_SIZE (regnum
)) == 0)
1730 /* Found a changed register. Save new value and return its number. */
1732 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1733 REGISTER_RAW_SIZE (regnum
));
1735 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(regnum
));
1739 * This section contains the commands that deal with tracepoints:
1742 /* return a list of all tracepoint numbers in interpreter */
1744 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
1745 ClientData clientData
;
1748 Tcl_Obj
*CONST objv
[];
1750 struct tracepoint
*tp
;
1752 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1754 ALL_TRACEPOINTS (tp
)
1755 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->number
));
1760 /* returns -1 if not found, tracepoint # if found */
1762 tracepoint_exists (char * args
)
1764 struct tracepoint
*tp
;
1766 struct symtabs_and_lines sals
;
1770 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1771 if (sals
.nelts
== 1)
1773 resolve_sal_pc (&sals
.sals
[0]);
1774 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
1775 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
1778 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
1779 strcat (file
, sals
.sals
[0].symtab
->filename
);
1781 ALL_TRACEPOINTS (tp
)
1783 if (tp
->address
== sals
.sals
[0].pc
)
1784 result
= tp
->number
;
1786 /* Why is this here? This messes up assembly traces */
1787 else if (tp
->source_file
!= NULL
1788 && strcmp (tp
->source_file
, file
) == 0
1789 && sals
.sals
[0].line
== tp
->line_number
)
1790 result
= tp
->number
;
1801 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
1802 ClientData clientData
;
1805 Tcl_Obj
*CONST objv
[];
1811 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1812 Tcl_GetStringFromObj (objv
[0], NULL
),
1813 " function:line|function|line|*addr\"", NULL
);
1817 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1819 Tcl_SetIntObj (result_ptr
->obj_ptr
, tracepoint_exists (args
));
1824 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
1825 ClientData clientData
;
1828 Tcl_Obj
*CONST objv
[];
1830 struct symtab_and_line sal
;
1832 struct tracepoint
*tp
;
1833 struct action_line
*al
;
1834 Tcl_Obj
*action_list
;
1835 char *filename
, *funcname
, *fname
;
1840 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1844 if (Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
) != TCL_OK
)
1846 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1850 ALL_TRACEPOINTS (tp
)
1851 if (tp
->number
== tpnum
)
1857 sprintf (buff
, "Tracepoint #%d does not exist", tpnum
);
1858 Tcl_SetStringObj (result_ptr
->obj_ptr
, buff
, -1);
1862 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1863 sal
= find_pc_line (tp
->address
, 0);
1864 filename
= symtab_to_filename (sal
.symtab
);
1865 if (filename
== NULL
)
1867 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1868 Tcl_NewStringObj (filename
, -1));
1870 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
1871 fname
= cplus_demangle (funcname
, 0);
1874 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj
1879 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj
1882 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (sal
.line
));
1883 sprintf (tmp
, "0x%lx", tp
->address
);
1884 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (tmp
, -1));
1885 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->enabled
));
1886 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->pass_count
));
1887 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->step_count
));
1888 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->thread
));
1889 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->hit_count
));
1891 /* Append a list of actions */
1892 action_list
= Tcl_NewObj ();
1893 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
1895 Tcl_ListObjAppendElement (interp
, action_list
,
1896 Tcl_NewStringObj (al
->action
, -1));
1898 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, action_list
);
1905 gdb_trace_status (clientData
, interp
, objc
, objv
)
1906 ClientData clientData
;
1909 Tcl_Obj
*CONST objv
[];
1913 if (trace_running_p
)
1916 Tcl_SetIntObj (result_ptr
->obj_ptr
, result
);
1923 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
1924 ClientData clientData
;
1927 Tcl_Obj
*CONST objv
[];
1931 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1932 Tcl_GetStringFromObj (objv
[0], NULL
),
1933 " linespec\"", NULL
);
1937 Tcl_SetIntObj (result_ptr
->obj_ptr
, get_traceframe_number ());
1942 /* This implements the tcl command gdb_actions
1943 * It sets actions for a given tracepoint.
1946 * number: the tracepoint in question
1947 * actions: the actions to add to this tracepoint
1953 gdb_actions_command (clientData
, interp
, objc
, objv
)
1954 ClientData clientData
;
1957 Tcl_Obj
*CONST objv
[];
1959 struct tracepoint
*tp
;
1961 int nactions
, i
, len
;
1962 char *number
, *args
, *action
;
1964 struct action_line
*next
= NULL
, *temp
;
1965 enum actionline_type linetype
;
1969 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # args: should be: \"",
1970 Tcl_GetStringFromObj (objv
[0], NULL
),
1971 " number actions\"", NULL
);
1975 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
1976 tp
= get_tracepoint_by_number (&args
);
1979 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "Tracepoint \"", number
, "\" does not exist", NULL
);
1983 /* Free any existing actions */
1984 if (tp
->actions
!= NULL
)
1989 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
1991 /* Add the actions to the tracepoint */
1992 for (i
= 0; i
< nactions
; i
++)
1994 temp
= xmalloc (sizeof (struct action_line
));
1996 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
1997 temp
->action
= savestring (action
, len
);
1999 linetype
= validate_actionline (&(temp
->action
), tp
);
2001 if (linetype
== BADLINE
)
2023 * This section has commands that handle source disassembly.
2026 /* This implements the tcl command gdb_disassemble
2029 * source_with_assm - must be "source" or "nosource"
2030 * low_address - the address from which to start disassembly
2031 * ?hi_address? - the address to which to disassemble, defaults
2032 * to the end of the function containing low_address.
2034 * The disassembled code is passed to fputs_unfiltered, so it
2035 * either goes to the console if result_ptr->obj_ptr is NULL or to
2040 gdb_disassemble (clientData
, interp
, objc
, objv
)
2041 ClientData clientData
;
2044 Tcl_Obj
*CONST objv
[];
2046 CORE_ADDR pc
, low
, high
;
2047 int mixed_source_and_assembly
;
2048 static disassemble_info di
;
2049 static int di_initialized
;
2052 if (objc
!= 3 && objc
!= 4)
2053 error ("wrong # args");
2055 if (! di_initialized
)
2057 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
2058 (fprintf_ftype
) fprintf_unfiltered
);
2059 di
.flavour
= bfd_target_unknown_flavour
;
2060 di
.memory_error_func
= dis_asm_memory_error
;
2061 di
.print_address_func
= dis_asm_print_address
;
2065 di
.mach
= tm_print_insn_info
.mach
;
2066 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
2067 di
.endian
= BFD_ENDIAN_BIG
;
2069 di
.endian
= BFD_ENDIAN_LITTLE
;
2071 arg_ptr
= Tcl_GetStringFromObj (objv
[1], NULL
);
2072 if (*arg_ptr
== 's' && strcmp (arg_ptr
, "source") == 0)
2073 mixed_source_and_assembly
= 1;
2074 else if (*arg_ptr
== 'n' && strcmp (arg_ptr
, "nosource") == 0)
2075 mixed_source_and_assembly
= 0;
2077 error ("First arg must be 'source' or 'nosource'");
2079 low
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[2], NULL
));
2083 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
2084 error ("No function contains specified address");
2087 high
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[3], NULL
));
2089 /* If disassemble_from_exec == -1, then we use the following heuristic to
2090 determine whether or not to do disassembly from target memory or from the
2093 If we're debugging a local process, read target memory, instead of the
2094 exec file. This makes disassembly of functions in shared libs work
2097 Else, we're debugging a remote process, and should disassemble from the
2098 exec file for speed. However, this is no good if the target modifies its
2099 code (for relocation, or whatever).
2102 if (disassemble_from_exec
== -1)
2104 if (strcmp (target_shortname
, "child") == 0
2105 || strcmp (target_shortname
, "procfs") == 0
2106 || strcmp (target_shortname
, "vxprocess") == 0)
2107 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
2109 disassemble_from_exec
= 1; /* It's remote, read the exec file */
2112 if (disassemble_from_exec
)
2113 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
2115 di
.read_memory_func
= dis_asm_read_memory
;
2117 /* If just doing straight assembly, all we need to do is disassemble
2118 everything between low and high. If doing mixed source/assembly, we've
2119 got a totally different path to follow. */
2121 if (mixed_source_and_assembly
)
2122 { /* Come here for mixed source/assembly */
2123 /* The idea here is to present a source-O-centric view of a function to
2124 the user. This means that things are presented in source order, with
2125 (possibly) out of order assembly immediately following. */
2126 struct symtab
*symtab
;
2127 struct linetable_entry
*le
;
2130 struct my_line_entry
*mle
;
2131 struct symtab_and_line sal
;
2136 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
2138 if (!symtab
|| !symtab
->linetable
)
2141 /* First, convert the linetable to a bunch of my_line_entry's. */
2143 le
= symtab
->linetable
->item
;
2144 nlines
= symtab
->linetable
->nitems
;
2149 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
2153 /* Copy linetable entries for this function into our data structure, creating
2154 end_pc's and setting out_of_order as appropriate. */
2156 /* First, skip all the preceding functions. */
2158 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
2160 /* Now, copy all entries before the end of this function. */
2163 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
2165 if (le
[i
].line
== le
[i
+ 1].line
2166 && le
[i
].pc
== le
[i
+ 1].pc
)
2167 continue; /* Ignore duplicates */
2169 mle
[newlines
].line
= le
[i
].line
;
2170 if (le
[i
].line
> le
[i
+ 1].line
)
2172 mle
[newlines
].start_pc
= le
[i
].pc
;
2173 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
2177 /* If we're on the last line, and it's part of the function, then we need to
2178 get the end pc in a special way. */
2183 mle
[newlines
].line
= le
[i
].line
;
2184 mle
[newlines
].start_pc
= le
[i
].pc
;
2185 sal
= find_pc_line (le
[i
].pc
, 0);
2186 mle
[newlines
].end_pc
= sal
.end
;
2190 /* Now, sort mle by line #s (and, then by addresses within lines). */
2193 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
2195 /* Now, for each line entry, emit the specified lines (unless they have been
2196 emitted before), followed by the assembly code for that line. */
2198 next_line
= 0; /* Force out first line */
2199 for (i
= 0; i
< newlines
; i
++)
2201 /* Print out everything from next_line to the current line. */
2203 if (mle
[i
].line
>= next_line
)
2206 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
2208 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
2210 next_line
= mle
[i
].line
+ 1;
2213 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
2216 fputs_unfiltered (" ", gdb_stdout
);
2217 print_address (pc
, gdb_stdout
);
2218 fputs_unfiltered (":\t ", gdb_stdout
);
2219 pc
+= (*tm_print_insn
) (pc
, &di
);
2220 fputs_unfiltered ("\n", gdb_stdout
);
2227 for (pc
= low
; pc
< high
; )
2230 fputs_unfiltered (" ", gdb_stdout
);
2231 print_address (pc
, gdb_stdout
);
2232 fputs_unfiltered (":\t ", gdb_stdout
);
2233 pc
+= (*tm_print_insn
) (pc
, &di
);
2234 fputs_unfiltered ("\n", gdb_stdout
);
2238 gdb_flush (gdb_stdout
);
2243 /* This is the memory_read_func for gdb_disassemble when we are
2244 disassembling from the exec file. */
2247 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
2251 disassemble_info
*info
;
2253 extern struct target_ops exec_ops
;
2257 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
2268 /* This will be passed to qsort to sort the results of the disassembly */
2271 compare_lines (mle1p
, mle2p
)
2275 struct my_line_entry
*mle1
, *mle2
;
2278 mle1
= (struct my_line_entry
*) mle1p
;
2279 mle2
= (struct my_line_entry
*) mle2p
;
2281 val
= mle1
->line
- mle2
->line
;
2286 return mle1
->start_pc
- mle2
->start_pc
;
2289 /* This implements the TCL command `gdb_loc',
2292 * ?symbol? The symbol or address to locate - defaults to pc
2294 * a list consisting of the following:
2295 * basename, function name, filename, line number, address, current pc
2299 gdb_loc (clientData
, interp
, objc
, objv
)
2300 ClientData clientData
;
2303 Tcl_Obj
*CONST objv
[];
2306 struct symtab_and_line sal
;
2307 char *funcname
, *fname
;
2310 if (!have_full_symbols () && !have_partial_symbols ())
2312 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No symbol table is loaded", -1);
2318 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
2320 /* Note - this next line is not correct on all architectures. */
2321 /* For a graphical debugger we really want to highlight the */
2322 /* assembly line that called the next function on the stack. */
2323 /* Many architectures have the next instruction saved as the */
2324 /* pc on the stack, so what happens is the next instruction is hughlighted. */
2326 pc
= selected_frame
->pc
;
2327 sal
= find_pc_line (selected_frame
->pc
,
2328 selected_frame
->next
!= NULL
2329 && !selected_frame
->next
->signal_handler_caller
2330 && !frame_in_dummy (selected_frame
->next
));
2335 sal
= find_pc_line (stop_pc
, 0);
2340 struct symtabs_and_lines sals
;
2343 sals
= decode_line_spec (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
2349 if (sals
.nelts
!= 1)
2351 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Ambiguous line spec", -1);
2358 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
2363 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2364 Tcl_NewStringObj (sal
.symtab
->filename
, -1));
2366 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewStringObj ("", 0));
2368 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
2369 fname
= cplus_demangle (funcname
, 0);
2372 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2373 Tcl_NewStringObj (fname
, -1));
2377 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2378 Tcl_NewStringObj (funcname
, -1));
2380 filename
= symtab_to_filename (sal
.symtab
);
2381 if (filename
== NULL
)
2384 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2385 Tcl_NewStringObj (filename
, -1));
2386 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(sal
.line
)); /* line number */
2387 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
2388 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
2392 /* This implements the Tcl command 'gdb_get_mem', which
2393 * dumps a block of memory
2395 * gdb_get_mem addr form size num aschar
2397 * addr: address of data to dump
2398 * form: a char indicating format
2399 * size: size of each element; 1,2,4, or 8 bytes
2400 * num: the number of bytes to read
2401 * acshar: an optional ascii character to use in ASCII dump
2404 * a list of elements followed by an optional ASCII dump
2408 gdb_get_mem (clientData
, interp
, objc
, objv
)
2409 ClientData clientData
;
2412 Tcl_Obj
*CONST objv
[];
2414 int size
, asize
, i
, j
, bc
;
2416 int nbytes
, rnum
, bpr
;
2418 char format
, c
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
2419 struct type
*val_type
;
2421 if (objc
< 6 || objc
> 7)
2423 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2424 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2428 if (Tcl_GetIntFromObj (interp
, objv
[3], &size
) != TCL_OK
)
2430 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2435 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid size, must be > 0", -1);
2439 if (Tcl_GetIntFromObj (interp
, objv
[4], &nbytes
) != TCL_OK
)
2441 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2446 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid number of bytes, must be > 0",
2451 if (Tcl_GetIntFromObj (interp
, objv
[5], &bpr
) != TCL_OK
)
2453 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2458 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid bytes per row, must be > 0", -1);
2462 if (Tcl_GetLongFromObj (interp
, objv
[1], &tmp
) != TCL_OK
)
2465 addr
= (CORE_ADDR
) tmp
;
2467 format
= *(Tcl_GetStringFromObj (objv
[2], NULL
));
2468 mbuf
= (char *)malloc (nbytes
+32);
2471 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Out of memory.", -1);
2475 memset (mbuf
, 0, nbytes
+32);
2478 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
2481 aschar
= *(Tcl_GetStringFromObj(objv
[6], NULL
));
2487 val_type
= builtin_type_char
;
2491 val_type
= builtin_type_short
;
2495 val_type
= builtin_type_int
;
2499 val_type
= builtin_type_long_long
;
2503 val_type
= builtin_type_char
;
2507 bc
= 0; /* count of bytes in a row */
2508 buff
[0] = '"'; /* buffer for ascii dump */
2509 bptr
= &buff
[1]; /* pointer for ascii dump */
2511 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Build up the result as a list... */
2513 for (i
=0; i
< nbytes
; i
+= size
)
2517 fputs_unfiltered ("N/A ", gdb_stdout
);
2519 for ( j
= 0; j
< size
; j
++)
2524 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
2528 for ( j
= 0; j
< size
; j
++)
2531 if (c
< 32 || c
> 126)
2543 if (aschar
&& (bc
>= bpr
))
2545 /* end of row. print it and reset variables */
2550 fputs_unfiltered (buff
, gdb_stdout
);
2555 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
2563 /* This implements the tcl command "gdb_loadfile"
2564 * It loads a c source file into a text widget.
2567 * widget: the name of the text widget to fill
2568 * filename: the name of the file to load
2569 * linenumbers: A boolean indicating whether or not to display line numbers.
2574 /* In this routine, we will build up a "line table", i.e. a
2575 * table of bits showing which lines in the source file are executible.
2576 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2578 * Its size limits the maximum number of lines
2579 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2580 * the file is loaded, so it is OK to make this very large.
2581 * Additional memory will be allocated if needed. */
2582 #define LTABLE_SIZE 20000
2584 gdb_loadfile (clientData
, interp
, objc
, objv
)
2585 ClientData clientData
;
2588 Tcl_Obj
*CONST objv
[];
2590 char *file
, *widget
;
2591 int linenumbers
, ln
, lnum
, ltable_size
;
2594 struct symtab
*symtab
;
2595 struct linetable_entry
*le
;
2598 Tcl_DString text_cmd_1
, text_cmd_2
, *cur_cmd
;
2599 char line
[1024], line_num_buf
[16];
2600 int prefix_len_1
, prefix_len_2
, cur_prefix_len
, widget_len
;
2605 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
2609 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
2610 if ( Tk_NameToWindow (interp
, widget
, Tk_MainWindow (interp
)) == NULL
)
2615 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
2616 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
2618 symtab
= full_lookup_symtab (file
);
2621 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "File not found in symtab", -1);
2626 file
= symtab_to_filename ( symtab
);
2627 if ((fp
= fopen ( file
, "r" )) == NULL
)
2629 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Can't open file for reading", -1);
2633 if (stat (file
, &st
) < 0)
2635 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
2640 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
2641 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
2643 mtime
= bfd_get_mtime(exec_bfd
);
2645 if (mtime
&& mtime
< st
.st_mtime
)
2646 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2649 /* Source linenumbers don't appear to be in order, and a sort is */
2650 /* too slow so the fastest solution is just to allocate a huge */
2651 /* array and set the array entry for each linenumber */
2653 ltable_size
= LTABLE_SIZE
;
2654 ltable
= (char *)malloc (LTABLE_SIZE
);
2657 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2662 memset (ltable
, 0, LTABLE_SIZE
);
2664 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
2666 le
= symtab
->linetable
->item
;
2667 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
2669 lnum
= le
->line
>> 3;
2670 if (lnum
>= ltable_size
)
2673 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
2674 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
2676 if (new_ltable
== NULL
)
2678 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2683 ltable
= new_ltable
;
2685 ltable
[lnum
] |= 1 << (le
->line
% 8);
2689 Tcl_DStringInit(&text_cmd_1
);
2690 Tcl_DStringInit(&text_cmd_2
);
2694 widget_len
= strlen (widget
);
2697 Tcl_DStringAppend (&text_cmd_1
, widget
, widget_len
);
2698 Tcl_DStringAppend (&text_cmd_2
, widget
, widget_len
);
2702 Tcl_DStringAppend (&text_cmd_1
, " insert end {-\t", -1);
2703 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2705 Tcl_DStringAppend (&text_cmd_2
, " insert end { \t", -1);
2706 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2708 while (fgets (line
+ 1, 980, fp
))
2710 sprintf (line_num_buf
, "%d", ln
);
2711 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2713 cur_cmd
= &text_cmd_1
;
2714 cur_prefix_len
= prefix_len_1
;
2715 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2716 Tcl_DStringAppend (cur_cmd
, "} break_rgn_tag", 15);
2720 cur_cmd
= &text_cmd_2
;
2721 cur_prefix_len
= prefix_len_2
;
2722 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2723 Tcl_DStringAppend (cur_cmd
, "} \"\"", 4);
2726 Tcl_DStringAppendElement (cur_cmd
, line
);
2727 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2729 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2730 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2736 Tcl_DStringAppend (&text_cmd_1
, " insert end {- } break_rgn_tag", -1);
2737 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2738 Tcl_DStringAppend (&text_cmd_2
, " insert end { } \"\"", -1);
2739 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2741 while (fgets (line
+ 1, 980, fp
))
2743 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2745 cur_cmd
= &text_cmd_1
;
2746 cur_prefix_len
= prefix_len_1
;
2750 cur_cmd
= &text_cmd_2
;
2751 cur_prefix_len
= prefix_len_2
;
2754 Tcl_DStringAppendElement (cur_cmd
, line
);
2755 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2757 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2758 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2764 Tcl_DStringFree (&text_cmd_1
);
2765 Tcl_DStringFree (&text_cmd_2
);
2772 * This section contains commands for manipulation of breakpoints.
2776 /* set a breakpoint by source file and line number */
2777 /* flags are as follows: */
2778 /* least significant 2 bits are disposition, rest is */
2779 /* type (normally 0).
2782 bp_breakpoint, Normal breakpoint
2783 bp_hardware_breakpoint, Hardware assisted breakpoint
2786 Disposition of breakpoint. Ie: what to do after hitting it.
2789 del_at_next_stop, Delete at next stop, whether hit or not
2791 donttouch Leave it alone
2795 /* This implements the tcl command "gdb_set_bp"
2796 * It sets breakpoints, and runs the Tcl command
2797 * gdbtk_tcl_breakpoint create
2798 * to register the new breakpoint with the GUI.
2801 * filename: the file in which to set the breakpoint
2802 * line: the line number for the breakpoint
2803 * type: the type of the breakpoint
2804 * thread: optional thread number
2806 * The return value of the call to gdbtk_tcl_breakpoint.
2810 gdb_set_bp (clientData
, interp
, objc
, objv
)
2811 ClientData clientData
;
2814 Tcl_Obj
*CONST objv
[];
2817 struct symtab_and_line sal
;
2818 int line
, flags
, ret
, thread
= -1;
2819 struct breakpoint
*b
;
2823 if (objc
!= 4 && objc
!= 5)
2825 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type [thread]");
2829 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
2830 if (sal
.symtab
== NULL
)
2833 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
2835 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2839 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
2841 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2847 if (Tcl_GetIntFromObj( interp
, objv
[4], &thread
) == TCL_ERROR
)
2849 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2855 if (!find_line_pc (sal
.symtab
, sal
.line
, &sal
.pc
))
2858 sal
.section
= find_pc_overlay (sal
.pc
);
2859 b
= set_raw_breakpoint (sal
);
2860 set_breakpoint_count (breakpoint_count
+ 1);
2861 b
->number
= breakpoint_count
;
2862 b
->type
= flags
>> 2;
2863 b
->disposition
= flags
& 3;
2866 /* FIXME: this won't work for duplicate basenames! */
2867 sprintf (buf
, "%s:%d", basename (Tcl_GetStringFromObj ( objv
[1], NULL
)), line
);
2868 b
->addr_string
= strsave (buf
);
2870 /* now send notification command back to GUI */
2872 Tcl_DStringInit (&cmd
);
2874 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2875 sprintf (buf
, "%d", b
->number
);
2876 Tcl_DStringAppendElement(&cmd
, buf
);
2877 sprintf (buf
, "0x%lx", (long)sal
.pc
);
2878 Tcl_DStringAppendElement (&cmd
, buf
);
2879 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[2], NULL
));
2880 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[1], NULL
));
2881 Tcl_DStringAppendElement (&cmd
, bpdisp
[b
->disposition
]);
2882 sprintf (buf
, "%d", b
->enable
);
2883 Tcl_DStringAppendElement (&cmd
, buf
);
2884 sprintf (buf
, "%d", b
->thread
);
2885 Tcl_DStringAppendElement (&cmd
, buf
);
2888 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2889 Tcl_DStringFree (&cmd
);
2893 /* This implements the tcl command "gdb_set_bp_addr"
2894 * It sets breakpoints, and runs the Tcl command
2895 * gdbtk_tcl_breakpoint create
2896 * to register the new breakpoint with the GUI.
2899 * addr: the address at which to set the breakpoint
2900 * type: the type of the breakpoint
2901 * thread: optional thread number
2903 * The return value of the call to gdbtk_tcl_breakpoint.
2907 gdb_set_bp_addr (clientData
, interp
, objc
, objv
)
2908 ClientData clientData
;
2911 Tcl_Obj
*CONST objv
[];
2914 struct symtab_and_line sal
;
2915 int line
, flags
, ret
, thread
= -1;
2917 struct breakpoint
*b
;
2918 char *filename
, buf
[64];
2921 if (objc
!= 4 && objc
!= 3)
2923 Tcl_WrongNumArgs(interp
, 1, objv
, "addr type ?thread?");
2927 if (Tcl_GetLongFromObj( interp
, objv
[1], &addr
) == TCL_ERROR
)
2929 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2933 if (Tcl_GetIntFromObj( interp
, objv
[2], &flags
) == TCL_ERROR
)
2935 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2941 if (Tcl_GetIntFromObj( interp
, objv
[3], &thread
) == TCL_ERROR
)
2943 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2948 sal
= find_pc_line (addr
, 0);
2950 b
= set_raw_breakpoint (sal
);
2951 set_breakpoint_count (breakpoint_count
+ 1);
2952 b
->number
= breakpoint_count
;
2953 b
->type
= flags
>> 2;
2954 b
->disposition
= flags
& 3;
2957 sprintf (buf
, "*(0x%lx)",addr
);
2958 b
->addr_string
= strsave (buf
);
2960 /* now send notification command back to GUI */
2962 Tcl_DStringInit (&cmd
);
2964 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2965 sprintf (buf
, "%d", b
->number
);
2966 Tcl_DStringAppendElement(&cmd
, buf
);
2967 sprintf (buf
, "0x%lx", addr
);
2968 Tcl_DStringAppendElement (&cmd
, buf
);
2969 sprintf (buf
, "%d", b
->line_number
);
2970 Tcl_DStringAppendElement (&cmd
, buf
);
2972 filename
= symtab_to_filename (sal
.symtab
);
2973 if (filename
== NULL
)
2975 Tcl_DStringAppendElement (&cmd
, filename
);
2976 Tcl_DStringAppendElement (&cmd
, bpdisp
[b
->disposition
]);
2977 sprintf (buf
, "%d", b
->enable
);
2978 Tcl_DStringAppendElement (&cmd
, buf
);
2979 sprintf (buf
, "%d", b
->thread
);
2980 Tcl_DStringAppendElement (&cmd
, buf
);
2982 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2983 Tcl_DStringFree (&cmd
);
2987 /* This implements the tcl command "gdb_find_bp_at_line"
2990 * filename: the file in which to find the breakpoint
2991 * line: the line number for the breakpoint
2993 * It returns a list of breakpoint numbers
2997 gdb_find_bp_at_line(clientData
, interp
, objc
, objv
)
2998 ClientData clientData
;
3001 Tcl_Obj
*CONST objv
[];
3006 struct breakpoint
*b
;
3007 extern struct breakpoint
*breakpoint_chain
;
3011 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line");
3015 s
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
3019 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
3021 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3025 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3026 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3027 if (b
->line_number
== line
&& !strcmp(b
->source_file
, s
->filename
))
3028 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3029 Tcl_NewIntObj (b
->number
));
3035 /* This implements the tcl command "gdb_find_bp_at_addr"
3040 * It returns a list of breakpoint numbers
3044 gdb_find_bp_at_addr(clientData
, interp
, objc
, objv
)
3045 ClientData clientData
;
3048 Tcl_Obj
*CONST objv
[];
3052 struct breakpoint
*b
;
3053 extern struct breakpoint
*breakpoint_chain
;
3057 Tcl_WrongNumArgs(interp
, 1, objv
, "address");
3061 if (Tcl_GetLongFromObj( interp
, objv
[1], &addr
) == TCL_ERROR
)
3063 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3067 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3068 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3069 if (b
->address
== (CORE_ADDR
)addr
)
3070 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3071 Tcl_NewIntObj (b
->number
));
3076 /* This implements the tcl command gdb_get_breakpoint_info
3082 * A list with {file, function, line_number, address, type, enabled?,
3083 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
3087 gdb_get_breakpoint_info (clientData
, interp
, objc
, objv
)
3088 ClientData clientData
;
3091 Tcl_Obj
*CONST objv
[];
3093 struct symtab_and_line sal
;
3094 struct command_line
*cmd
;
3096 struct breakpoint
*b
;
3097 extern struct breakpoint
*breakpoint_chain
;
3098 char *funcname
, *fname
, *filename
;
3103 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong number of args, should be \"breakpoint\"", -1);
3107 if ( Tcl_GetIntFromObj(NULL
, objv
[1], &bpnum
) != TCL_OK
)
3109 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3113 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3114 if (b
->number
== bpnum
)
3117 if (!b
|| b
->type
!= bp_breakpoint
)
3120 sprintf(err_buf
, "Breakpoint #%d does not exist.", bpnum
);
3121 Tcl_SetStringObj (result_ptr
->obj_ptr
, err_buf
, -1);
3125 sal
= find_pc_line (b
->address
, 0);
3127 filename
= symtab_to_filename (sal
.symtab
);
3128 if (filename
== NULL
)
3131 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3132 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3133 Tcl_NewStringObj (filename
, -1));
3135 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
3136 fname
= cplus_demangle (funcname
, 0);
3139 new_obj
= Tcl_NewStringObj (fname
, -1);
3143 new_obj
= Tcl_NewStringObj (funcname
, -1);
3145 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
3147 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->line_number
));
3148 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%lx", b
->address
);
3149 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3150 Tcl_NewStringObj (bptypes
[b
->type
], -1));
3151 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewBooleanObj(b
->enable
== enabled
));
3152 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3153 Tcl_NewStringObj (bpdisp
[b
->disposition
], -1));
3154 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->ignore_count
));
3156 new_obj
= Tcl_NewObj();
3157 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
3158 Tcl_ListObjAppendElement (NULL
, new_obj
,
3159 Tcl_NewStringObj (cmd
->line
, -1));
3160 Tcl_ListObjAppendElement(NULL
, result_ptr
->obj_ptr
, new_obj
);
3162 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3163 Tcl_NewStringObj (b
->cond_string
, -1));
3165 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->thread
));
3166 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->hit_count
));
3172 /* This implements the tcl command gdb_get_breakpoint_list
3173 * It builds up a list of the current breakpoints.
3178 * A list of breakpoint numbers.
3182 gdb_get_breakpoint_list (clientData
, interp
, objc
, objv
)
3183 ClientData clientData
;
3186 Tcl_Obj
*CONST objv
[];
3188 struct breakpoint
*b
;
3189 extern struct breakpoint
*breakpoint_chain
;
3193 error ("wrong number of args, none are allowed");
3195 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3196 if (b
->type
== bp_breakpoint
)
3198 new_obj
= Tcl_NewIntObj (b
->number
);
3199 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
3205 /* The functions in this section deal with stacks and backtraces. */
3207 /* This implements the tcl command gdb_stack.
3208 * It builds up a list of stack frames.
3211 * start - starting stack frame
3212 * count - number of frames to inspect
3214 * A list of function names
3218 gdb_stack (clientData
, interp
, objc
, objv
) ClientData clientData
;
3221 Tcl_Obj
*CONST objv
[];
3227 Tcl_WrongNumArgs (interp
, 1, objv
, "start count");
3228 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3232 if (Tcl_GetIntFromObj (NULL
, objv
[1], &start
))
3234 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3237 if (Tcl_GetIntFromObj (NULL
, objv
[2], &count
))
3239 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3243 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
3245 if (target_has_stack
)
3247 struct frame_info
*top
;
3248 struct frame_info
*fi
;
3250 /* Find the outermost frame */
3251 fi
= get_current_frame ();
3255 fi
= get_prev_frame (fi
);
3258 /* top now points to the top (outermost frame) of the
3259 stack, so point it to the requested start */
3261 top
= find_relative_frame (top
, &start
);
3263 /* If start != 0, then we have asked to start outputting
3264 frames beyond the innermost stack frame */
3268 while (fi
&& count
--)
3270 get_frame_name (interp
, result_ptr
->obj_ptr
, fi
);
3271 fi
= get_next_frame (fi
);
3279 /* A helper function for get_stack which adds information about
3280 * the stack frame FI to the caller's LIST.
3282 * This is stolen from print_frame_info in stack.c.
3285 get_frame_name (interp
, list
, fi
)
3288 struct frame_info
*fi
;
3290 struct symtab_and_line sal
;
3291 struct symbol
*func
= NULL
;
3292 register char *funname
= 0;
3293 enum language funlang
= language_unknown
;
3296 if (frame_in_dummy (fi
))
3298 objv
[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
3299 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3302 if (fi
->signal_handler_caller
)
3304 objv
[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
3305 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3310 find_pc_line (fi
->pc
,
3312 && !fi
->next
->signal_handler_caller
3313 && !frame_in_dummy (fi
->next
));
3315 func
= find_pc_function (fi
->pc
);
3318 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3320 && (SYMBOL_VALUE_ADDRESS (msymbol
)
3321 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
3324 funname
= SYMBOL_NAME (msymbol
);
3325 funlang
= SYMBOL_LANGUAGE (msymbol
);
3329 funname
= SYMBOL_NAME (func
);
3330 funlang
= SYMBOL_LANGUAGE (func
);
3335 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3336 if (msymbol
!= NULL
)
3338 funname
= SYMBOL_NAME (msymbol
);
3339 funlang
= SYMBOL_LANGUAGE (msymbol
);
3347 if (funlang
== language_cplus
)
3348 name
= cplus_demangle (funname
, 0);
3352 objv
[0] = Tcl_NewStringObj (name
, -1);
3353 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3358 /* we have no convenient way to deal with this yet... */
3359 if (fi
->pc
!= sal
.pc
|| !sal
.symtab
)
3361 print_address_numeric (fi
->pc
, 1, gdb_stdout
);
3362 printf_filtered (" in ");
3364 printf_symbol_filtered (gdb_stdout
, funname
? funname
: "??", funlang
,
3367 objv
[0] = Tcl_NewStringObj (funname
!= NULL
? funname
: "??", -1);
3368 #ifdef PC_LOAD_SEGMENT
3369 /* If we couldn't print out function name but if can figure out what
3370 load segment this pc value is from, at least print out some info
3371 about its load segment. */
3374 Tcl_AppendStringsToObj (objv
[0], " from ", PC_LOAD_SEGMENT (fi
->pc
),
3381 char *lib
= PC_SOLIB (fi
->pc
);
3384 Tcl_AppendStringsToObj (objv
[0], " from ", lib
, (char *) NULL
);
3388 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3394 * This section contains a bunch of miscellaneous utility commands
3397 /* This implements the tcl command gdb_path_conv
3399 * On Windows, it canonicalizes the pathname,
3400 * On Unix, it is a no op.
3405 * The canonicalized path.
3409 gdb_path_conv (clientData
, interp
, objc
, objv
)
3410 ClientData clientData
;
3413 Tcl_Obj
*CONST objv
[];
3416 error ("wrong # args");
3420 char pathname
[256], *ptr
;
3422 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj(objv
[1], NULL
), pathname
);
3423 for (ptr
= pathname
; *ptr
; ptr
++)
3428 Tcl_SetStringObj (result_ptr
->obj_ptr
, pathname
, -1);
3431 Tcl_SetStringObj (result_ptr
->obj_ptr
, Tcl_GetStringFromObj (objv
[1], NULL
), -1);
3438 * This section has utility routines that are not Tcl commands.
3442 perror_with_name_wrapper (args
)
3445 perror_with_name (args
);
3449 /* The lookup_symtab() in symtab.c doesn't work correctly */
3450 /* It will not work will full pathnames and if multiple */
3451 /* source files have the same basename, it will return */
3452 /* the first one instead of the correct one. This version */
3453 /* also always makes sure symtab->fullname is set. */
3455 static struct symtab
*
3456 full_lookup_symtab(file
)
3460 struct objfile
*objfile
;
3461 char *bfile
, *fullname
;
3462 struct partial_symtab
*pt
;
3467 /* first try a direct lookup */
3468 st
= lookup_symtab (file
);
3472 symtab_to_filename(st
);
3476 /* if the direct approach failed, try */
3477 /* looking up the basename and checking */
3478 /* all matches with the fullname */
3479 bfile
= basename (file
);
3480 ALL_SYMTABS (objfile
, st
)
3482 if (!strcmp (bfile
, basename(st
->filename
)))
3485 fullname
= symtab_to_filename (st
);
3487 fullname
= st
->fullname
;
3489 if (!strcmp (file
, fullname
))
3494 /* still no luck? look at psymtabs */
3495 ALL_PSYMTABS (objfile
, pt
)
3497 if (!strcmp (bfile
, basename(pt
->filename
)))
3499 st
= PSYMTAB_TO_SYMTAB (pt
);
3502 fullname
= symtab_to_filename (st
);
3503 if (!strcmp (file
, fullname
))