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"
47 /* start-sanitize-ide */
53 /* 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;
160 extern int gdb_variable_init
PARAMS ((Tcl_Interp
*interp
));
163 * Declarations for routines exported from this file
166 int Gdbtk_Init (Tcl_Interp
*interp
);
167 int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
170 * Declarations for routines used only in this file.
173 static int compare_lines
PARAMS ((const PTR
, const PTR
));
174 static int comp_files
PARAMS ((const void *, const void *));
175 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
176 Tcl_Obj
*CONST objv
[]));
177 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
178 static int gdb_clear_file
PARAMS ((ClientData
, Tcl_Interp
*interp
, int, Tcl_Obj
*CONST
[]));
179 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
180 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
181 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int,
183 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
184 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
185 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
186 Tcl_Obj
*CONST objv
[]));
187 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
188 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
189 static int gdb_get_args_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
190 Tcl_Obj
*CONST objv
[]));
191 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
192 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
193 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
194 Tcl_Obj
*CONST objv
[]));
195 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
196 Tcl_Obj
*CONST objv
[]));
197 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
198 Tcl_Obj
*CONST objv
[]));
199 static int gdb_get_locals_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
200 Tcl_Obj
*CONST objv
[]));
201 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
202 static int gdb_get_trace_frame_num
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
203 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int,
204 Tcl_Obj
*CONST objv
[]));
205 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
206 Tcl_Obj
*CONST objv
[]));
207 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
208 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
209 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
210 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
211 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
212 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
213 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
214 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
215 Tcl_Obj
*CONST objv
[]));
216 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
217 static int gdb_search
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
219 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
220 static int gdb_set_bp_addr
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
221 static int gdb_find_bp_at_line
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
222 static int gdb_find_bp_at_addr
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
223 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
224 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*,
227 static int gdb_trace_status
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
228 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*,
230 Tcl_Obj
*CONST objv
[]));
231 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int,
232 Tcl_Obj
*CONST objv
[]));
233 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
234 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
235 static int gdb_stack
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
237 char * get_prompt
PARAMS ((void));
238 static void get_register
PARAMS ((int, void *));
239 static void get_register_name
PARAMS ((int, void *));
240 static int map_arg_registers
PARAMS ((int, Tcl_Obj
*CONST
[], void (*) (int, void *), void *));
241 static int perror_with_name_wrapper
PARAMS ((char *args
));
242 static void register_changed_p
PARAMS ((int, void *));
243 void TclDebug
PARAMS ((const char *fmt
, ...));
244 static int wrapped_call (char *opaque_args
);
245 static void get_frame_name
PARAMS ((Tcl_Interp
*interp
, Tcl_Obj
*list
, struct frame_info
*fi
));
248 * This loads all the Tcl commands into the Tcl interpreter.
251 * interp - The interpreter into which to load the commands.
254 * A standard Tcl result.
261 Tcl_CreateObjCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
262 Tcl_CreateObjCommand (interp
, "gdb_immediate", call_wrapper
,
263 gdb_immediate_command
, NULL
);
264 Tcl_CreateObjCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
265 Tcl_CreateObjCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
266 Tcl_CreateObjCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
, NULL
);
267 Tcl_CreateObjCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
269 Tcl_CreateObjCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
271 Tcl_CreateObjCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
272 Tcl_CreateObjCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
273 Tcl_CreateObjCommand (interp
, "gdb_fetch_registers", call_wrapper
,
274 gdb_fetch_registers
, NULL
);
275 Tcl_CreateObjCommand (interp
, "gdb_changed_register_list", call_wrapper
,
276 gdb_changed_register_list
, NULL
);
277 Tcl_CreateObjCommand (interp
, "gdb_disassemble", call_wrapper
,
278 gdb_disassemble
, NULL
);
279 Tcl_CreateObjCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
280 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
281 gdb_get_breakpoint_list
, NULL
);
282 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
283 gdb_get_breakpoint_info
, NULL
);
284 Tcl_CreateObjCommand (interp
, "gdb_clear_file", call_wrapper
,
285 gdb_clear_file
, NULL
);
286 Tcl_CreateObjCommand (interp
, "gdb_confirm_quit", call_wrapper
,
287 gdb_confirm_quit
, NULL
);
288 Tcl_CreateObjCommand (interp
, "gdb_force_quit", call_wrapper
,
289 gdb_force_quit
, NULL
);
290 Tcl_CreateObjCommand (interp
, "gdb_target_has_execution",
292 gdb_target_has_execution_command
, NULL
);
293 Tcl_CreateObjCommand (interp
, "gdb_is_tracing",
294 call_wrapper
, gdb_trace_status
,
296 Tcl_CreateObjCommand (interp
, "gdb_load_info", call_wrapper
, gdb_load_info
, NULL
);
297 Tcl_CreateObjCommand (interp
, "gdb_get_locals", call_wrapper
, gdb_get_locals_command
,
299 Tcl_CreateObjCommand (interp
, "gdb_get_args", call_wrapper
, gdb_get_args_command
,
301 Tcl_CreateObjCommand (interp
, "gdb_get_function", call_wrapper
, gdb_get_function_command
,
303 Tcl_CreateObjCommand (interp
, "gdb_get_line", call_wrapper
, gdb_get_line_command
,
305 Tcl_CreateObjCommand (interp
, "gdb_get_file", call_wrapper
, gdb_get_file_command
,
307 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
308 call_wrapper
, gdb_tracepoint_exists_command
, NULL
);
309 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
310 call_wrapper
, gdb_get_tracepoint_info
, NULL
);
311 Tcl_CreateObjCommand (interp
, "gdb_actions",
312 call_wrapper
, gdb_actions_command
, NULL
);
313 Tcl_CreateObjCommand (interp
, "gdb_prompt",
314 call_wrapper
, gdb_prompt_command
, NULL
);
315 Tcl_CreateObjCommand (interp
, "gdb_find_file",
316 call_wrapper
, gdb_find_file_command
, NULL
);
317 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
318 call_wrapper
, gdb_get_tracepoint_list
, NULL
);
319 Tcl_CreateObjCommand (interp
, "gdb_pc_reg", call_wrapper
, get_pc_register
, NULL
);
320 Tcl_CreateObjCommand (interp
, "gdb_loadfile", call_wrapper
, gdb_loadfile
, NULL
);
321 Tcl_CreateObjCommand (gdbtk_interp
, "gdb_search", call_wrapper
,
323 Tcl_CreateObjCommand (interp
, "gdb_set_bp", call_wrapper
, gdb_set_bp
, NULL
);
324 Tcl_CreateObjCommand (interp
, "gdb_set_bp_addr", call_wrapper
, gdb_set_bp_addr
, NULL
);
325 Tcl_CreateObjCommand (interp
, "gdb_find_bp_at_line", call_wrapper
, gdb_find_bp_at_line
, NULL
);
326 Tcl_CreateObjCommand (interp
, "gdb_find_bp_at_addr", call_wrapper
, gdb_find_bp_at_addr
, NULL
);
327 Tcl_CreateObjCommand (interp
, "gdb_get_trace_frame_num",
328 call_wrapper
, gdb_get_trace_frame_num
, NULL
);
329 Tcl_CreateObjCommand (interp
, "gdb_stack", call_wrapper
, gdb_stack
, NULL
);
331 Tcl_LinkVar (interp
, "gdb_selected_frame_level",
332 (char *) &selected_frame_level
,
333 TCL_LINK_INT
| TCL_LINK_READ_ONLY
);
335 /* gdb_context is used for debugging multiple threads or tasks */
336 Tcl_LinkVar (interp
, "gdb_context_id",
337 (char *) &gdb_context
,
338 TCL_LINK_INT
| TCL_LINK_READ_ONLY
);
340 /* Init variable interface...*/
341 if (gdb_variable_init (interp
) != TCL_OK
)
344 /* Determine where to disassemble from */
345 Tcl_LinkVar (gdbtk_interp
, "disassemble-from-exec", (char *) &disassemble_from_exec
,
348 Tcl_PkgProvide(interp
, "Gdbtk", GDBTK_VERSION
);
352 /* This routine acts as a top-level for all GDB code called by Tcl/Tk. It
353 handles cleanups, and uses catch_errors to trap calls to return_to_top_level
355 This is necessary in order to prevent a longjmp out of the bowels of Tk,
356 possibly leaving things in a bad state. Since this routine can be called
357 recursively, it needs to save and restore the contents of the result_ptr as
361 call_wrapper (clientData
, interp
, objc
, objv
)
362 ClientData clientData
;
365 Tcl_Obj
*CONST objv
[];
367 struct wrapped_call_args wrapped_args
;
368 gdbtk_result new_result
, *old_result_ptr
;
370 old_result_ptr
= result_ptr
;
371 result_ptr
= &new_result
;
372 result_ptr
->obj_ptr
= Tcl_NewObj();
373 result_ptr
->flags
= GDBTK_TO_RESULT
;
375 wrapped_args
.func
= (Tcl_ObjCmdProc
*) clientData
;
376 wrapped_args
.interp
= interp
;
377 wrapped_args
.objc
= objc
;
378 wrapped_args
.objv
= objv
;
379 wrapped_args
.val
= TCL_OK
;
381 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
384 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
386 /* Make sure the timer interrupts are turned off. */
390 gdb_flush (gdb_stderr
); /* Flush error output */
391 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
393 /* If we errored out here, and the results were going to the
394 console, then gdbtk_fputs will have gathered the result into the
395 result_ptr. We also need to echo them out to the console here */
397 gdb_flush (gdb_stderr
); /* Flush error output */
398 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
400 /* In case of an error, we may need to force the GUI into idle
401 mode because gdbtk_call_command may have bombed out while in
402 the command routine. */
405 Tcl_Eval (interp
, "gdbtk_tcl_idle");
409 /* do not suppress any errors -- a remote target could have errored */
410 load_in_progress
= 0;
413 * Now copy the result over to the true Tcl result. If GDBTK_TO_RESULT flag
414 * bit is set , this just copies a null object over to the Tcl result, which is
415 * fine because we should reset the result in this case anyway.
417 if (result_ptr
->flags
& GDBTK_IN_TCL_RESULT
)
419 Tcl_DecrRefCount(result_ptr
->obj_ptr
);
423 Tcl_SetObjResult (interp
, result_ptr
->obj_ptr
);
426 result_ptr
= old_result_ptr
;
432 return wrapped_args
.val
;
436 * This is the wrapper that is passed to catch_errors.
440 wrapped_call (opaque_args
)
443 struct wrapped_call_args
*args
= (struct wrapped_call_args
*) opaque_args
;
444 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->objc
, args
->objv
);
448 /* This is a convenience function to sprintf something(s) into a
449 * new element in a Tcl list object.
453 #ifdef ANSI_PROTOTYPES
454 sprintf_append_element_to_obj (Tcl_Obj
*objp
, char *format
, ...)
456 sprintf_append_element_to_obj (va_alist
)
463 #ifdef ANSI_PROTOTYPES
464 va_start (args
, format
);
470 dsp
= va_arg (args
, Tcl_Obj
*);
471 format
= va_arg (args
, char *);
474 vsprintf (buf
, format
, args
);
476 Tcl_ListObjAppendElement (NULL
, objp
, Tcl_NewStringObj (buf
, -1));
480 * This section contains the commands that control execution.
483 /* This implements the tcl command gdb_clear_file.
485 * Prepare to accept a new executable file. This is called when we
486 * want to clear away everything we know about the old file, without
487 * asking the user. The Tcl code will have already asked the user if
488 * necessary. After this is called, we should be able to run the
489 * `file' command without getting any questions.
498 gdb_clear_file (clientData
, interp
, objc
, objv
)
499 ClientData clientData
;
502 Tcl_Obj
*CONST objv
[];
505 Tcl_SetStringObj (result_ptr
->obj_ptr
,
506 "Wrong number of args, none are allowed.", -1);
508 if (inferior_pid
!= 0 && target_has_execution
)
511 target_detach (NULL
, 0);
516 if (target_has_execution
)
519 symbol_file_command (NULL
, 0);
521 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
522 clear it here. FIXME: This seems like an abstraction violation
529 /* This implements the tcl command gdb_confirm_quit
530 * Ask the user to confirm an exit request.
535 * A boolean, 1 if the user answered yes, 0 if no.
539 gdb_confirm_quit (clientData
, interp
, objc
, objv
)
540 ClientData clientData
;
543 Tcl_Obj
*CONST objv
[];
549 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
553 ret
= quit_confirm ();
554 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, ret
);
558 /* This implements the tcl command gdb_force_quit
559 * Quit without asking for confirmation.
568 gdb_force_quit (clientData
, interp
, objc
, objv
)
569 ClientData clientData
;
572 Tcl_Obj
*CONST objv
[];
576 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
580 quit_force ((char *) NULL
, 1);
584 /* This implements the tcl command gdb_stop
585 * It stops the target in a continuable fashion.
594 gdb_stop (clientData
, interp
, objc
, objv
)
595 ClientData clientData
;
598 Tcl_Obj
*CONST objv
[];
600 if (target_stop
!= target_ignore
)
603 quit_flag
= 1; /* hope something sees this */
610 * This section contains Tcl commands that are wrappers for invoking
611 * the GDB command interpreter.
615 /* This implements the tcl command `gdb_eval'.
616 * It uses the gdb evaluator to return the value of
617 * an expression in the current language
620 * expression - the expression to evaluate.
622 * The result of the evaluation.
626 gdb_eval (clientData
, interp
, objc
, objv
)
627 ClientData clientData
;
630 Tcl_Obj
*CONST objv
[];
632 struct expression
*expr
;
633 struct cleanup
*old_chain
=NULL
;
638 Tcl_SetStringObj (result_ptr
->obj_ptr
,
639 "wrong # args, should be \"gdb_eval expression\"", -1);
643 expr
= parse_expression (Tcl_GetStringFromObj (objv
[1], NULL
));
645 old_chain
= make_cleanup ((make_cleanup_func
) free_current_contents
, &expr
);
647 val
= evaluate_expression (expr
);
650 * Print the result of the expression evaluation. This will go to
651 * eventually go to gdbtk_fputs, and from there be collected into
655 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
),
656 VALUE_EMBEDDED_OFFSET(val
), VALUE_ADDRESS (val
),
657 gdb_stdout
, 0, 0, 0, 0);
659 do_cleanups (old_chain
);
664 /* This implements the tcl command "gdb_cmd".
666 * It sends its argument to the GDB command scanner for execution.
667 * This command will never cause the update, idle and busy hooks to be called
671 * command - The GDB command to execute
672 * from_tty - 1 indicates this comes to the console. Pass this to the gdb command.
674 * The output from the gdb command (except for the "load" & "while"
675 * which dump their output to the console.
679 gdb_cmd (clientData
, interp
, objc
, objv
)
680 ClientData clientData
;
683 Tcl_Obj
*CONST objv
[];
689 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
695 if (Tcl_GetBooleanFromObj (NULL
, objv
[2], &from_tty
) != TCL_OK
) {
696 Tcl_SetStringObj (result_ptr
->obj_ptr
, "from_tty must be a boolean.",
702 if (running_now
|| load_in_progress
)
707 /* for the load instruction (and possibly others later) we
708 set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
709 will not buffer all the data until the command is finished. */
711 if ((strncmp ("load ", Tcl_GetStringFromObj (objv
[1], NULL
), 5) == 0))
713 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
714 load_in_progress
= 1;
717 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), from_tty
);
719 if (load_in_progress
)
721 load_in_progress
= 0;
722 result_ptr
->flags
|= GDBTK_TO_RESULT
;
725 bpstat_do_actions (&stop_bpstat
);
731 * This implements the tcl command "gdb_immediate"
733 * It does exactly the same thing as gdb_cmd, except NONE of its outut
734 * is buffered. This will also ALWAYS cause the busy, update, and idle hooks to
735 * be called, contrasted with gdb_cmd, which NEVER calls them.
736 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
737 * to the console window.
740 * command - The GDB command to execute
741 * from_tty - 1 to indicate this is from the console.
747 gdb_immediate_command (clientData
, interp
, objc
, objv
)
748 ClientData clientData
;
751 Tcl_Obj
*CONST objv
[];
758 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
764 if (Tcl_GetBooleanFromObj (NULL
, objv
[2], &from_tty
) != TCL_OK
) {
765 Tcl_SetStringObj (result_ptr
->obj_ptr
, "from_tty must be a boolean.",
771 if (running_now
|| load_in_progress
)
776 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
778 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), from_tty
);
780 bpstat_do_actions (&stop_bpstat
);
782 result_ptr
->flags
|= GDBTK_TO_RESULT
;
787 /* This implements the tcl command "gdb_prompt"
789 * It returns the gdb interpreter's prompt.
798 gdb_prompt_command (clientData
, interp
, objc
, objv
)
799 ClientData clientData
;
802 Tcl_Obj
*CONST objv
[];
804 Tcl_SetStringObj (result_ptr
->obj_ptr
, get_prompt (), -1);
810 * This section contains general informational commands.
813 /* This implements the tcl command "gdb_target_has_execution"
815 * Tells whether the target is executing.
820 * A boolean indicating whether the target is executing.
824 gdb_target_has_execution_command (clientData
, interp
, objc
, objv
)
825 ClientData clientData
;
828 Tcl_Obj
*CONST objv
[];
832 if (target_has_execution
&& inferior_pid
!= 0)
835 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, result
);
839 /* This implements the tcl command "gdb_load_info"
841 * It returns information about the file about to be downloaded.
844 * filename: The file to open & get the info on.
846 * A list consisting of the name and size of each section.
850 gdb_load_info (clientData
, interp
, objc
, objv
)
851 ClientData clientData
;
854 Tcl_Obj
*CONST objv
[];
857 struct cleanup
*old_cleanups
;
861 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
863 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
864 if (loadfile_bfd
== NULL
)
866 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Open failed", -1);
869 old_cleanups
= make_cleanup ((make_cleanup_func
) bfd_close
, loadfile_bfd
);
871 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
873 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Bad Object File", -1);
877 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
879 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
881 if (s
->flags
& SEC_LOAD
)
883 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
886 ob
[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd
, s
), -1);
887 ob
[1] = Tcl_NewLongObj ((long) size
);
888 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewListObj (2, ob
));
893 do_cleanups (old_cleanups
);
899 * This and gdb_get_locals just call gdb_get_vars_command with the right
900 * value of clientData. We can't use the client data in the definition
901 * of the command, because the call wrapper uses this instead...
905 gdb_get_locals_command (clientData
, interp
, objc
, objv
)
906 ClientData clientData
;
909 Tcl_Obj
*CONST objv
[];
912 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
917 gdb_get_args_command (clientData
, interp
, objc
, objv
)
918 ClientData clientData
;
921 Tcl_Obj
*CONST objv
[];
924 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
928 /* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
930 * This function sets the Tcl interpreter's result to a list of variable names
931 * depending on clientData. If clientData is one, the result is a list of
932 * arguments; zero returns a list of locals -- all relative to the block
933 * specified as an argument to the command. Valid commands include
934 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
938 * block - the address within which to specify the locals or args.
940 * A list of the locals or args
944 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
945 ClientData clientData
;
948 Tcl_Obj
*CONST objv
[];
950 struct symtabs_and_lines sals
;
953 char **canonical
, *args
;
954 int i
, nsyms
, arguments
;
958 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
,
959 "wrong # of args: should be \"",
960 Tcl_GetStringFromObj (objv
[0], NULL
),
961 " function:line|function|line|*addr\"", NULL
);
965 arguments
= (int) clientData
;
966 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
967 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
970 Tcl_SetStringObj (result_ptr
->obj_ptr
,
971 "error decoding line", -1);
975 /* Initialize the result pointer to an empty list. */
977 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
979 /* Resolve all line numbers to PC's */
980 for (i
= 0; i
< sals
.nelts
; i
++)
981 resolve_sal_pc (&sals
.sals
[i
]);
983 block
= block_for_pc (sals
.sals
[0].pc
);
986 nsyms
= BLOCK_NSYMS (block
);
987 for (i
= 0; i
< nsyms
; i
++)
989 sym
= BLOCK_SYM (block
, i
);
990 switch (SYMBOL_CLASS (sym
)) {
992 case LOC_UNDEF
: /* catches errors */
993 case LOC_CONST
: /* constant */
994 case LOC_TYPEDEF
: /* local typedef */
995 case LOC_LABEL
: /* local label */
996 case LOC_BLOCK
: /* local function */
997 case LOC_CONST_BYTES
: /* loc. byte seq. */
998 case LOC_UNRESOLVED
: /* unresolved static */
999 case LOC_OPTIMIZED_OUT
: /* optimized out */
1001 case LOC_ARG
: /* argument */
1002 case LOC_REF_ARG
: /* reference arg */
1003 case LOC_REGPARM
: /* register arg */
1004 case LOC_REGPARM_ADDR
: /* indirect register arg */
1005 case LOC_LOCAL_ARG
: /* stack arg */
1006 case LOC_BASEREG_ARG
: /* basereg arg */
1008 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1009 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
1011 case LOC_LOCAL
: /* stack local */
1012 case LOC_BASEREG
: /* basereg local */
1013 case LOC_STATIC
: /* static */
1014 case LOC_REGISTER
: /* register */
1016 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1017 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
1021 if (BLOCK_FUNCTION (block
))
1024 block
= BLOCK_SUPERBLOCK (block
);
1030 /* This implements the tcl command "gdb_get_line"
1032 * It returns the linenumber for a given linespec. It will take any spec
1033 * that can be passed to decode_line_1
1036 * linespec - the line specification
1038 * The line number for that spec.
1041 gdb_get_line_command (clientData
, interp
, objc
, objv
)
1042 ClientData clientData
;
1045 Tcl_Obj
*CONST objv
[];
1047 struct symtabs_and_lines sals
;
1048 char *args
, **canonical
;
1052 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1053 Tcl_GetStringFromObj (objv
[0], NULL
),
1054 " linespec\"", NULL
);
1058 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1059 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1060 if (sals
.nelts
== 1)
1062 Tcl_SetIntObj (result_ptr
->obj_ptr
, sals
.sals
[0].line
);
1066 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1071 /* This implements the tcl command "gdb_get_file"
1073 * It returns the file containing a given line spec.
1076 * linespec - The linespec to look up
1078 * The file containing it.
1082 gdb_get_file_command (clientData
, interp
, objc
, objv
)
1083 ClientData clientData
;
1086 Tcl_Obj
*CONST objv
[];
1088 struct symtabs_and_lines sals
;
1089 char *args
, **canonical
;
1093 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1094 Tcl_GetStringFromObj (objv
[0], NULL
),
1095 " linespec\"", NULL
);
1099 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1100 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1101 if (sals
.nelts
== 1)
1103 Tcl_SetStringObj (result_ptr
->obj_ptr
, sals
.sals
[0].symtab
->filename
, -1);
1107 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1111 /* This implements the tcl command "gdb_get_function"
1113 * It finds the function containing the given line spec.
1116 * linespec - The line specification
1118 * The function that contains it, or "N/A" if it is not in a function.
1121 gdb_get_function_command (clientData
, interp
, objc
, objv
)
1122 ClientData clientData
;
1125 Tcl_Obj
*CONST objv
[];
1128 struct symtabs_and_lines sals
;
1129 char *args
, **canonical
;
1133 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1134 Tcl_GetStringFromObj (objv
[0], NULL
),
1135 " linespec\"", NULL
);
1139 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1140 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1141 if (sals
.nelts
== 1)
1143 resolve_sal_pc (&sals
.sals
[0]);
1144 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
1145 if (function
!= NULL
)
1147 Tcl_SetStringObj (result_ptr
->obj_ptr
, function
, -1);
1152 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1156 /* This implements the tcl command "gdb_find_file"
1158 * It searches the symbol tables to get the full pathname to a file.
1161 * filename: the file name to search for.
1163 * The full path to the file, or an empty string if the file is not
1168 gdb_find_file_command (clientData
, interp
, objc
, objv
)
1169 ClientData clientData
;
1172 Tcl_Obj
*CONST objv
[];
1174 char *filename
= NULL
;
1179 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
1183 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1185 filename
= st
->fullname
;
1187 if (filename
== NULL
)
1188 Tcl_SetStringObj (result_ptr
->obj_ptr
, "", 0);
1190 Tcl_SetStringObj (result_ptr
->obj_ptr
, filename
, -1);
1195 /* This implements the tcl command "gdb_listfiles"
1197 * This lists all the files in the current executible.
1199 * Note that this currently pulls in all sorts of filenames
1200 * that aren't really part of the executable. It would be
1201 * best if we could check each file to see if it actually
1202 * contains executable lines of code, but we can't do that
1206 * ?pathname? - If provided, only files which match pathname
1207 * (up to strlen(pathname)) are included. THIS DOES NOT
1208 * CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1209 * THE FULL PATHNAME!!!
1212 * A list of all matching files.
1215 gdb_listfiles (clientData
, interp
, objc
, objv
)
1216 ClientData clientData
;
1219 Tcl_Obj
*CONST objv
[];
1221 struct objfile
*objfile
;
1222 struct partial_symtab
*psymtab
;
1223 struct symtab
*symtab
;
1224 char *lastfile
, *pathname
=NULL
, **files
;
1226 int i
, numfiles
= 0, len
= 0;
1229 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1233 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1237 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1239 ALL_PSYMTABS (objfile
, psymtab
)
1241 if (numfiles
== files_size
)
1243 files_size
= files_size
* 2;
1244 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1246 if (psymtab
->filename
)
1248 if (!len
|| !strncmp(pathname
, psymtab
->filename
,len
)
1249 || !strcmp(psymtab
->filename
, basename(psymtab
->filename
)))
1251 files
[numfiles
++] = basename(psymtab
->filename
);
1256 ALL_SYMTABS (objfile
, symtab
)
1258 if (numfiles
== files_size
)
1260 files_size
= files_size
* 2;
1261 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1263 if (symtab
->filename
&& symtab
->linetable
&& symtab
->linetable
->nitems
)
1265 if (!len
|| !strncmp(pathname
, symtab
->filename
,len
)
1266 || !strcmp(symtab
->filename
, basename(symtab
->filename
)))
1268 files
[numfiles
++] = basename(symtab
->filename
);
1273 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1277 /* Discard the old result pointer, in case it has accumulated anything
1278 and set it to a new list object */
1280 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1282 for (i
= 0; i
< numfiles
; i
++)
1284 if (strcmp(files
[i
],lastfile
))
1285 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj(files
[i
], -1));
1286 lastfile
= files
[i
];
1294 comp_files (file1
, file2
)
1295 const void *file1
, *file2
;
1297 return strcmp(* (char **) file1
, * (char **) file2
);
1301 /* This implements the tcl command "gdb_search"
1305 * option - One of "functions", "variables" or "types"
1306 * regexp - The regular expression to look for.
1315 gdb_search (clientData
, interp
, objc
, objv
)
1316 ClientData clientData
;
1319 Tcl_Obj
*CONST objv
[];
1321 struct symbol_search
*ss
= NULL
;
1322 struct symbol_search
*p
;
1323 struct cleanup
*old_chain
= NULL
;
1324 Tcl_Obj
*CONST
*switch_objv
;
1325 int index
, switch_objc
, i
;
1326 namespace_enum space
= 0;
1328 int static_only
, nfiles
;
1329 Tcl_Obj
**file_list
;
1331 static char *search_options
[] = { "functions", "variables", "types", (char *) NULL
};
1332 static char *switches
[] = { "-files", "-static", (char *) NULL
};
1333 enum search_opts
{ SEARCH_FUNCTIONS
, SEARCH_VARIABLES
, SEARCH_TYPES
};
1334 enum switches_opts
{ SWITCH_FILES
, SWITCH_STATIC_ONLY
};
1338 Tcl_WrongNumArgs (interp
, 1, objv
, "option regexp ?arg ...?");
1339 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1343 if (Tcl_GetIndexFromObj (interp
, objv
[1], search_options
, "option", 0,
1346 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1350 /* Unfortunately, we cannot teach search_symbols to search on
1351 multiple regexps, so we have to do a two-tier search for
1352 any searches which choose to narrow the playing field. */
1353 switch ((enum search_opts
) index
)
1355 case SEARCH_FUNCTIONS
:
1356 space
= FUNCTIONS_NAMESPACE
; break;
1357 case SEARCH_VARIABLES
:
1358 space
= VARIABLES_NAMESPACE
; break;
1360 space
= TYPES_NAMESPACE
; break;
1363 regexp
= Tcl_GetStringFromObj (objv
[2], NULL
);
1364 /* Process any switches that refine the search */
1365 switch_objc
= objc
- 3;
1366 switch_objv
= objv
+ 3;
1370 files
= (char **) NULL
;
1371 while (switch_objc
> 0)
1373 if (Tcl_GetIndexFromObj (interp
, switch_objv
[0], switches
,
1374 "option", 0, &index
) != TCL_OK
)
1376 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1380 switch ((enum switches_opts
) index
)
1385 if (switch_objc
< 2)
1387 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList -static 1|0]");
1388 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1391 result
= Tcl_ListObjGetElements (interp
, switch_objv
[1], &nfiles
, &file_list
);
1392 if (result
!= TCL_OK
)
1395 files
= (char **) xmalloc (nfiles
* sizeof (char *));
1396 for (i
= 0; i
< nfiles
; i
++)
1397 files
[i
] = Tcl_GetStringFromObj (file_list
[i
], NULL
);
1402 case SWITCH_STATIC_ONLY
:
1403 if (switch_objc
< 2)
1405 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList] [-static 1|0]");
1406 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1409 if ( Tcl_GetBooleanFromObj (interp
, switch_objv
[1], &static_only
) !=
1411 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1421 search_symbols (regexp
, space
, nfiles
, files
, &ss
);
1423 old_chain
= make_cleanup ((make_cleanup_func
) free_search_symbols
, ss
);
1425 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1427 for (p
= ss
; p
!= NULL
; p
= p
->next
)
1431 if (static_only
&& p
->block
!= STATIC_BLOCK
)
1434 /* Strip off some C++ special symbols, like RTTI and global
1435 constructors/destructors. */
1436 if ((p
->symbol
!= NULL
&& !STREQN (SYMBOL_NAME (p
->symbol
), "__tf", 4)
1437 && !STREQN (SYMBOL_NAME (p
->symbol
), "_GLOBAL_", 8))
1438 || p
->msymbol
!= NULL
)
1440 elem
= Tcl_NewListObj (0, NULL
);
1442 if (p
->msymbol
== NULL
)
1443 Tcl_ListObjAppendElement (interp
, elem
,
1444 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->symbol
), -1));
1446 Tcl_ListObjAppendElement (interp
, elem
,
1447 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->msymbol
), -1));
1449 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, elem
);
1454 do_cleanups (old_chain
);
1459 /* This implements the tcl command gdb_listfuncs
1461 * It lists all the functions defined in a given file
1464 * file - the file to look in
1466 * A list of two element lists, the first element is
1467 * the symbol name, and the second is a boolean indicating
1468 * whether the symbol is demangled (1 for yes).
1472 gdb_listfuncs (clientData
, interp
, objc
, objv
)
1473 ClientData clientData
;
1476 Tcl_Obj
*CONST objv
[];
1478 struct symtab
*symtab
;
1479 struct blockvector
*bv
;
1483 Tcl_Obj
*funcVals
[2];
1487 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1490 symtab
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1493 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No such file", -1);
1497 if (mangled
== NULL
)
1499 mangled
= Tcl_NewBooleanObj(1);
1500 not_mangled
= Tcl_NewBooleanObj(0);
1501 Tcl_IncrRefCount(mangled
);
1502 Tcl_IncrRefCount(not_mangled
);
1505 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1507 bv
= BLOCKVECTOR (symtab
);
1508 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1510 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1511 /* Skip the sort if this block is always sorted. */
1512 if (!BLOCK_SHOULD_SORT (b
))
1513 sort_block_syms (b
);
1514 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1516 sym
= BLOCK_SYM (b
, j
);
1517 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1520 char *name
= SYMBOL_DEMANGLED_NAME (sym
);
1524 /* strip out "global constructors" and "global destructors" */
1525 /* because we aren't interested in them. */
1526 if (strncmp (name
, "global ", 7))
1528 /* If the function is overloaded, print out the functions
1529 declaration, not just its name. */
1531 funcVals
[0] = Tcl_NewStringObj(name
, -1);
1532 funcVals
[1] = mangled
;
1540 funcVals
[0] = Tcl_NewStringObj(SYMBOL_NAME(sym
), -1);
1541 funcVals
[1] = not_mangled
;
1543 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1544 Tcl_NewListObj (2, funcVals
));
1553 * This section contains all the commands that act on the registers:
1556 /* This is a sort of mapcar function for operations on registers */
1559 map_arg_registers (objc
, objv
, func
, argp
)
1561 Tcl_Obj
*CONST objv
[];
1562 void (*func
) PARAMS ((int regnum
, void *argp
));
1567 /* Note that the test for a valid register must include checking the
1568 REGISTER_NAME because NUM_REGS may be allocated for the union of
1569 the register sets within a family of related processors. In this
1570 case, some entries of REGISTER_NAME will change depending upon
1571 the particular processor being debugged. */
1573 if (objc
== 0) /* No args, just do all the regs */
1577 && REGISTER_NAME (regnum
) != NULL
1578 && *REGISTER_NAME (regnum
) != '\000';
1580 func (regnum
, argp
);
1585 /* Else, list of register #s, just do listed regs */
1586 for (; objc
> 0; objc
--, objv
++)
1588 if (Tcl_GetIntFromObj (NULL
, *objv
, ®num
) != TCL_OK
)
1590 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1595 && regnum
< NUM_REGS
1596 && REGISTER_NAME (regnum
) != NULL
1597 && *REGISTER_NAME (regnum
) != '\000')
1598 func (regnum
, argp
);
1601 Tcl_SetStringObj (result_ptr
->obj_ptr
, "bad register number", -1);
1609 /* This implements the TCL command `gdb_regnames', which returns a list of
1610 all of the register names. */
1613 gdb_regnames (clientData
, interp
, objc
, objv
)
1614 ClientData clientData
;
1617 Tcl_Obj
*CONST objv
[];
1622 return map_arg_registers (objc
, objv
, get_register_name
, NULL
);
1626 get_register_name (regnum
, argp
)
1628 void *argp
; /* Ignored */
1630 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1631 Tcl_NewStringObj (REGISTER_NAME (regnum
), -1));
1634 /* This implements the tcl command gdb_fetch_registers
1635 * Pass it a list of register names, and it will
1636 * return their values as a list.
1639 * format: The format string for printing the values
1640 * args: the registers to look for
1642 * A list of their values.
1646 gdb_fetch_registers (clientData
, interp
, objc
, objv
)
1647 ClientData clientData
;
1650 Tcl_Obj
*CONST objv
[];
1656 Tcl_SetStringObj (result_ptr
->obj_ptr
,
1657 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
1661 format
= *(Tcl_GetStringFromObj(objv
[0], NULL
));
1665 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Output the results as a list */
1666 result
= map_arg_registers (objc
, objv
, get_register
, (void *) format
);
1667 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
1673 get_register (regnum
, fp
)
1677 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1678 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
1679 int format
= (int)fp
;
1685 /* read_relative_register_raw_bytes returns a virtual frame pointer
1686 (FRAME_FP (selected_frame)) if regnum == FP_REGNUM instead
1687 of the real contents of the register. To get around this,
1688 use get_saved_register instead. */
1689 get_saved_register (raw_buffer
, &optim
, (CORE_ADDR
*) NULL
, selected_frame
,
1690 regnum
, (enum lval_type
*) NULL
);
1693 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1694 Tcl_NewStringObj ("Optimized out", -1));
1698 /* Convert raw data to virtual format if necessary. */
1700 if (REGISTER_CONVERTIBLE (regnum
))
1702 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
1703 raw_buffer
, virtual_buffer
);
1706 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1711 printf_filtered ("0x");
1712 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1714 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1715 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1716 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
1720 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0, 0,
1721 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1725 /* This implements the tcl command get_pc_reg
1726 * It returns the value of the PC register
1731 * The value of the pc register.
1735 get_pc_register (clientData
, interp
, objc
, objv
)
1736 ClientData clientData
;
1739 Tcl_Obj
*CONST objv
[];
1743 sprintf (buff
, "0x%llx",(long long) read_register (PC_REGNUM
));
1744 Tcl_SetStringObj(result_ptr
->obj_ptr
, buff
, -1);
1748 /* This implements the tcl command "gdb_changed_register_list"
1749 * It takes a list of registers, and returns a list of
1750 * the registers on that list that have changed since the last
1751 * time the proc was called.
1754 * A list of registers.
1756 * A list of changed registers.
1760 gdb_changed_register_list (clientData
, interp
, objc
, objv
)
1761 ClientData clientData
;
1764 Tcl_Obj
*CONST objv
[];
1769 return map_arg_registers (objc
, objv
, register_changed_p
, NULL
);
1773 register_changed_p (regnum
, argp
)
1775 void *argp
; /* Ignored */
1777 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1779 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1782 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1783 REGISTER_RAW_SIZE (regnum
)) == 0)
1786 /* Found a changed register. Save new value and return its number. */
1788 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1789 REGISTER_RAW_SIZE (regnum
));
1791 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(regnum
));
1795 * This section contains the commands that deal with tracepoints:
1798 /* return a list of all tracepoint numbers in interpreter */
1800 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
1801 ClientData clientData
;
1804 Tcl_Obj
*CONST objv
[];
1806 struct tracepoint
*tp
;
1808 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1810 ALL_TRACEPOINTS (tp
)
1811 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->number
));
1816 /* returns -1 if not found, tracepoint # if found */
1818 tracepoint_exists (char * args
)
1820 struct tracepoint
*tp
;
1822 struct symtabs_and_lines sals
;
1826 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1827 if (sals
.nelts
== 1)
1829 resolve_sal_pc (&sals
.sals
[0]);
1830 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
1831 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
1834 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
1835 strcat (file
, sals
.sals
[0].symtab
->filename
);
1837 ALL_TRACEPOINTS (tp
)
1839 if (tp
->address
== sals
.sals
[0].pc
)
1840 result
= tp
->number
;
1842 /* Why is this here? This messes up assembly traces */
1843 else if (tp
->source_file
!= NULL
1844 && strcmp (tp
->source_file
, file
) == 0
1845 && sals
.sals
[0].line
== tp
->line_number
)
1846 result
= tp
->number
;
1857 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
1858 ClientData clientData
;
1861 Tcl_Obj
*CONST objv
[];
1867 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1868 Tcl_GetStringFromObj (objv
[0], NULL
),
1869 " function:line|function|line|*addr\"", NULL
);
1873 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1875 Tcl_SetIntObj (result_ptr
->obj_ptr
, tracepoint_exists (args
));
1880 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
1881 ClientData clientData
;
1884 Tcl_Obj
*CONST objv
[];
1886 struct symtab_and_line sal
;
1888 struct tracepoint
*tp
;
1889 struct action_line
*al
;
1890 Tcl_Obj
*action_list
;
1891 char *filename
, *funcname
, *fname
;
1896 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1900 if (Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
) != TCL_OK
)
1902 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1906 ALL_TRACEPOINTS (tp
)
1907 if (tp
->number
== tpnum
)
1913 sprintf (buff
, "Tracepoint #%d does not exist", tpnum
);
1914 Tcl_SetStringObj (result_ptr
->obj_ptr
, buff
, -1);
1918 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1919 sal
= find_pc_line (tp
->address
, 0);
1920 filename
= symtab_to_filename (sal
.symtab
);
1921 if (filename
== NULL
)
1923 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1924 Tcl_NewStringObj (filename
, -1));
1926 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
1927 fname
= cplus_demangle (funcname
, 0);
1930 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj
1935 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj
1938 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (sal
.line
));
1939 sprintf (tmp
, "0x%lx", tp
->address
);
1940 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (tmp
, -1));
1941 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->enabled
));
1942 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->pass_count
));
1943 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->step_count
));
1944 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->thread
));
1945 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->hit_count
));
1947 /* Append a list of actions */
1948 action_list
= Tcl_NewObj ();
1949 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
1951 Tcl_ListObjAppendElement (interp
, action_list
,
1952 Tcl_NewStringObj (al
->action
, -1));
1954 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, action_list
);
1961 gdb_trace_status (clientData
, interp
, objc
, objv
)
1962 ClientData clientData
;
1965 Tcl_Obj
*CONST objv
[];
1969 if (trace_running_p
)
1972 Tcl_SetIntObj (result_ptr
->obj_ptr
, result
);
1979 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
1980 ClientData clientData
;
1983 Tcl_Obj
*CONST objv
[];
1987 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1988 Tcl_GetStringFromObj (objv
[0], NULL
),
1989 " linespec\"", NULL
);
1993 Tcl_SetIntObj (result_ptr
->obj_ptr
, get_traceframe_number ());
1998 /* This implements the tcl command gdb_actions
1999 * It sets actions for a given tracepoint.
2002 * number: the tracepoint in question
2003 * actions: the actions to add to this tracepoint
2009 gdb_actions_command (clientData
, interp
, objc
, objv
)
2010 ClientData clientData
;
2013 Tcl_Obj
*CONST objv
[];
2015 struct tracepoint
*tp
;
2017 int nactions
, i
, len
;
2018 char *number
, *args
, *action
;
2020 struct action_line
*next
= NULL
, *temp
;
2021 enum actionline_type linetype
;
2025 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # args: should be: \"",
2026 Tcl_GetStringFromObj (objv
[0], NULL
),
2027 " number actions\"", NULL
);
2031 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
2032 tp
= get_tracepoint_by_number (&args
);
2035 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "Tracepoint \"", number
, "\" does not exist", NULL
);
2039 /* Free any existing actions */
2040 if (tp
->actions
!= NULL
)
2045 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
2047 /* Add the actions to the tracepoint */
2048 for (i
= 0; i
< nactions
; i
++)
2050 temp
= xmalloc (sizeof (struct action_line
));
2052 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
2053 temp
->action
= savestring (action
, len
);
2055 linetype
= validate_actionline (&(temp
->action
), tp
);
2057 if (linetype
== BADLINE
)
2079 * This section has commands that handle source disassembly.
2082 /* This implements the tcl command gdb_disassemble
2085 * source_with_assm - must be "source" or "nosource"
2086 * low_address - the address from which to start disassembly
2087 * ?hi_address? - the address to which to disassemble, defaults
2088 * to the end of the function containing low_address.
2090 * The disassembled code is passed to fputs_unfiltered, so it
2091 * either goes to the console if result_ptr->obj_ptr is NULL or to
2096 gdb_disassemble (clientData
, interp
, objc
, objv
)
2097 ClientData clientData
;
2100 Tcl_Obj
*CONST objv
[];
2102 CORE_ADDR pc
, low
, high
;
2103 int mixed_source_and_assembly
;
2104 static disassemble_info di
;
2105 static int di_initialized
;
2108 if (objc
!= 3 && objc
!= 4)
2109 error ("wrong # args");
2111 if (! di_initialized
)
2113 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
2114 (fprintf_ftype
) fprintf_unfiltered
);
2115 di
.flavour
= bfd_target_unknown_flavour
;
2116 di
.memory_error_func
= dis_asm_memory_error
;
2117 di
.print_address_func
= dis_asm_print_address
;
2121 di
.mach
= TARGET_PRINT_INSN_INFO
->mach
;
2122 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
2123 di
.endian
= BFD_ENDIAN_BIG
;
2125 di
.endian
= BFD_ENDIAN_LITTLE
;
2127 arg_ptr
= Tcl_GetStringFromObj (objv
[1], NULL
);
2128 if (*arg_ptr
== 's' && strcmp (arg_ptr
, "source") == 0)
2129 mixed_source_and_assembly
= 1;
2130 else if (*arg_ptr
== 'n' && strcmp (arg_ptr
, "nosource") == 0)
2131 mixed_source_and_assembly
= 0;
2133 error ("First arg must be 'source' or 'nosource'");
2135 low
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[2], NULL
));
2139 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
2140 error ("No function contains specified address");
2143 high
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[3], NULL
));
2145 /* If disassemble_from_exec == -1, then we use the following heuristic to
2146 determine whether or not to do disassembly from target memory or from the
2149 If we're debugging a local process, read target memory, instead of the
2150 exec file. This makes disassembly of functions in shared libs work
2153 Else, we're debugging a remote process, and should disassemble from the
2154 exec file for speed. However, this is no good if the target modifies its
2155 code (for relocation, or whatever).
2158 if (disassemble_from_exec
== -1)
2160 if (strcmp (target_shortname
, "child") == 0
2161 || strcmp (target_shortname
, "procfs") == 0
2162 || strcmp (target_shortname
, "vxprocess") == 0)
2163 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
2165 disassemble_from_exec
= 1; /* It's remote, read the exec file */
2168 if (disassemble_from_exec
)
2169 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
2171 di
.read_memory_func
= dis_asm_read_memory
;
2173 /* If just doing straight assembly, all we need to do is disassemble
2174 everything between low and high. If doing mixed source/assembly, we've
2175 got a totally different path to follow. */
2177 if (mixed_source_and_assembly
)
2178 { /* Come here for mixed source/assembly */
2179 /* The idea here is to present a source-O-centric view of a function to
2180 the user. This means that things are presented in source order, with
2181 (possibly) out of order assembly immediately following. */
2182 struct symtab
*symtab
;
2183 struct linetable_entry
*le
;
2186 struct my_line_entry
*mle
;
2187 struct symtab_and_line sal
;
2192 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
2194 if (!symtab
|| !symtab
->linetable
)
2197 /* First, convert the linetable to a bunch of my_line_entry's. */
2199 le
= symtab
->linetable
->item
;
2200 nlines
= symtab
->linetable
->nitems
;
2205 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
2209 /* Copy linetable entries for this function into our data structure, creating
2210 end_pc's and setting out_of_order as appropriate. */
2212 /* First, skip all the preceding functions. */
2214 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
2216 /* Now, copy all entries before the end of this function. */
2219 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
2221 if (le
[i
].line
== le
[i
+ 1].line
2222 && le
[i
].pc
== le
[i
+ 1].pc
)
2223 continue; /* Ignore duplicates */
2225 mle
[newlines
].line
= le
[i
].line
;
2226 if (le
[i
].line
> le
[i
+ 1].line
)
2228 mle
[newlines
].start_pc
= le
[i
].pc
;
2229 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
2233 /* If we're on the last line, and it's part of the function, then we need to
2234 get the end pc in a special way. */
2239 mle
[newlines
].line
= le
[i
].line
;
2240 mle
[newlines
].start_pc
= le
[i
].pc
;
2241 sal
= find_pc_line (le
[i
].pc
, 0);
2242 mle
[newlines
].end_pc
= sal
.end
;
2246 /* Now, sort mle by line #s (and, then by addresses within lines). */
2249 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
2251 /* Now, for each line entry, emit the specified lines (unless they have been
2252 emitted before), followed by the assembly code for that line. */
2254 next_line
= 0; /* Force out first line */
2255 for (i
= 0; i
< newlines
; i
++)
2257 /* Print out everything from next_line to the current line. */
2259 if (mle
[i
].line
>= next_line
)
2262 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
2264 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
2266 next_line
= mle
[i
].line
+ 1;
2269 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
2272 fputs_unfiltered (" ", gdb_stdout
);
2273 print_address (pc
, gdb_stdout
);
2274 fputs_unfiltered (":\t ", gdb_stdout
);
2275 pc
+= (*tm_print_insn
) (pc
, &di
);
2276 fputs_unfiltered ("\n", gdb_stdout
);
2283 for (pc
= low
; pc
< high
; )
2286 fputs_unfiltered (" ", gdb_stdout
);
2287 print_address (pc
, gdb_stdout
);
2288 fputs_unfiltered (":\t ", gdb_stdout
);
2289 pc
+= (*tm_print_insn
) (pc
, &di
);
2290 fputs_unfiltered ("\n", gdb_stdout
);
2294 gdb_flush (gdb_stdout
);
2299 /* This is the memory_read_func for gdb_disassemble when we are
2300 disassembling from the exec file. */
2303 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
2307 disassemble_info
*info
;
2309 extern struct target_ops exec_ops
;
2313 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
2324 /* This will be passed to qsort to sort the results of the disassembly */
2327 compare_lines (mle1p
, mle2p
)
2331 struct my_line_entry
*mle1
, *mle2
;
2334 mle1
= (struct my_line_entry
*) mle1p
;
2335 mle2
= (struct my_line_entry
*) mle2p
;
2337 val
= mle1
->line
- mle2
->line
;
2342 return mle1
->start_pc
- mle2
->start_pc
;
2345 /* This implements the TCL command `gdb_loc',
2348 * ?symbol? The symbol or address to locate - defaults to pc
2350 * a list consisting of the following:
2351 * basename, function name, filename, line number, address, current pc
2355 gdb_loc (clientData
, interp
, objc
, objv
)
2356 ClientData clientData
;
2359 Tcl_Obj
*CONST objv
[];
2362 struct symtab_and_line sal
;
2364 char *funcname
, *fname
;
2369 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
2371 /* Note - this next line is not correct on all architectures. */
2372 /* For a graphical debugger we really want to highlight the */
2373 /* assembly line that called the next function on the stack. */
2374 /* Many architectures have the next instruction saved as the */
2375 /* pc on the stack, so what happens is the next instruction */
2376 /* is highlighted. FIXME */
2377 pc
= selected_frame
->pc
;
2378 sal
= find_pc_line (selected_frame
->pc
,
2379 selected_frame
->next
!= NULL
2380 && !selected_frame
->next
->signal_handler_caller
2381 && !frame_in_dummy (selected_frame
->next
));
2386 sal
= find_pc_line (stop_pc
, 0);
2391 struct symtabs_and_lines sals
;
2394 sals
= decode_line_spec (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
2400 if (sals
.nelts
!= 1)
2402 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Ambiguous line spec", -1);
2405 resolve_sal_pc (&sal
);
2410 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
2415 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2416 Tcl_NewStringObj (sal
.symtab
->filename
, -1));
2418 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewStringObj ("", 0));
2420 sym
= find_pc_function (pc
);
2423 fname
= SYMBOL_DEMANGLED_NAME (sym
);
2426 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2427 Tcl_NewStringObj (fname
, -1));
2430 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2431 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2435 /* find_pc_function will fail if there are only minimal symbols */
2436 /* so do this instead... */
2437 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
2438 /* we try cplus demangling; a guess really */
2439 fname
= cplus_demangle (funcname
, 0);
2442 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2443 Tcl_NewStringObj (fname
, -1));
2447 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2448 Tcl_NewStringObj (funcname
, -1));
2451 filename
= symtab_to_filename (sal
.symtab
);
2452 if (filename
== NULL
)
2456 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2457 Tcl_NewStringObj (filename
, -1));
2459 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(sal
.line
));
2460 /* PC in current frame */
2461 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(pc
));
2463 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(stop_pc
));
2465 /* shared library */
2467 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2468 Tcl_NewStringObj (PC_SOLIB(pc
), -1));
2470 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2471 Tcl_NewStringObj ("", -1));
2476 /* This implements the Tcl command 'gdb_get_mem', which
2477 * dumps a block of memory
2479 * gdb_get_mem addr form size num aschar
2481 * addr: address of data to dump
2482 * form: a char indicating format
2483 * size: size of each element; 1,2,4, or 8 bytes
2484 * num: the number of bytes to read
2485 * acshar: an optional ascii character to use in ASCII dump
2488 * a list of elements followed by an optional ASCII dump
2492 gdb_get_mem (clientData
, interp
, objc
, objv
)
2493 ClientData clientData
;
2496 Tcl_Obj
*CONST objv
[];
2498 int size
, asize
, i
, j
, bc
;
2500 int nbytes
, rnum
, bpr
;
2502 char format
, c
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
2503 struct type
*val_type
;
2505 if (objc
< 6 || objc
> 7)
2507 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2508 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2512 if (Tcl_GetIntFromObj (interp
, objv
[3], &size
) != TCL_OK
)
2514 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2519 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid size, must be > 0", -1);
2523 if (Tcl_GetIntFromObj (interp
, objv
[4], &nbytes
) != TCL_OK
)
2525 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2530 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid number of bytes, must be > 0",
2535 if (Tcl_GetIntFromObj (interp
, objv
[5], &bpr
) != TCL_OK
)
2537 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2542 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid bytes per row, must be > 0", -1);
2546 if (Tcl_GetLongFromObj (interp
, objv
[1], &tmp
) != TCL_OK
)
2549 addr
= (CORE_ADDR
) tmp
;
2551 format
= *(Tcl_GetStringFromObj (objv
[2], NULL
));
2552 mbuf
= (char *)malloc (nbytes
+32);
2555 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Out of memory.", -1);
2559 memset (mbuf
, 0, nbytes
+32);
2562 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
2565 aschar
= *(Tcl_GetStringFromObj(objv
[6], NULL
));
2571 val_type
= builtin_type_char
;
2575 val_type
= builtin_type_short
;
2579 val_type
= builtin_type_int
;
2583 val_type
= builtin_type_long_long
;
2587 val_type
= builtin_type_char
;
2591 bc
= 0; /* count of bytes in a row */
2592 buff
[0] = '"'; /* buffer for ascii dump */
2593 bptr
= &buff
[1]; /* pointer for ascii dump */
2595 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Build up the result as a list... */
2597 for (i
=0; i
< nbytes
; i
+= size
)
2601 fputs_unfiltered ("N/A ", gdb_stdout
);
2603 for ( j
= 0; j
< size
; j
++)
2608 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
2612 for ( j
= 0; j
< size
; j
++)
2615 if (c
< 32 || c
> 126)
2627 if (aschar
&& (bc
>= bpr
))
2629 /* end of row. print it and reset variables */
2634 fputs_unfiltered (buff
, gdb_stdout
);
2639 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
2647 /* This implements the tcl command "gdb_loadfile"
2648 * It loads a c source file into a text widget.
2651 * widget: the name of the text widget to fill
2652 * filename: the name of the file to load
2653 * linenumbers: A boolean indicating whether or not to display line numbers.
2658 /* In this routine, we will build up a "line table", i.e. a
2659 * table of bits showing which lines in the source file are executible.
2660 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2662 * Its size limits the maximum number of lines
2663 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2664 * the file is loaded, so it is OK to make this very large.
2665 * Additional memory will be allocated if needed. */
2666 #define LTABLE_SIZE 20000
2668 gdb_loadfile (clientData
, interp
, objc
, objv
)
2669 ClientData clientData
;
2672 Tcl_Obj
*CONST objv
[];
2674 char *file
, *widget
;
2675 int linenumbers
, ln
, lnum
, ltable_size
;
2678 struct symtab
*symtab
;
2679 struct linetable_entry
*le
;
2682 Tcl_DString text_cmd_1
, text_cmd_2
, *cur_cmd
;
2683 char line
[10000], line_num_buf
[16];
2684 int prefix_len_1
, prefix_len_2
, cur_prefix_len
, widget_len
;
2689 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
2693 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
2694 if ( Tk_NameToWindow (interp
, widget
, Tk_MainWindow (interp
)) == NULL
)
2699 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
2700 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
2702 symtab
= full_lookup_symtab (file
);
2705 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "File not found in symtab", -1);
2710 file
= symtab_to_filename ( symtab
);
2711 if ((fp
= fopen ( file
, "r" )) == NULL
)
2713 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Can't open file for reading", -1);
2717 if (stat (file
, &st
) < 0)
2719 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
2724 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
2725 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
2727 mtime
= bfd_get_mtime(exec_bfd
);
2729 if (mtime
&& mtime
< st
.st_mtime
)
2730 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2733 /* Source linenumbers don't appear to be in order, and a sort is */
2734 /* too slow so the fastest solution is just to allocate a huge */
2735 /* array and set the array entry for each linenumber */
2737 ltable_size
= LTABLE_SIZE
;
2738 ltable
= (char *)malloc (LTABLE_SIZE
);
2741 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2746 memset (ltable
, 0, LTABLE_SIZE
);
2748 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
2750 le
= symtab
->linetable
->item
;
2751 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
2753 lnum
= le
->line
>> 3;
2754 if (lnum
>= ltable_size
)
2757 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
2758 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
2760 if (new_ltable
== NULL
)
2762 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2767 ltable
= new_ltable
;
2769 ltable
[lnum
] |= 1 << (le
->line
% 8);
2773 Tcl_DStringInit(&text_cmd_1
);
2774 Tcl_DStringInit(&text_cmd_2
);
2778 widget_len
= strlen (widget
);
2781 Tcl_DStringAppend (&text_cmd_1
, widget
, widget_len
);
2782 Tcl_DStringAppend (&text_cmd_2
, widget
, widget_len
);
2786 Tcl_DStringAppend (&text_cmd_1
, " insert end {-\t", -1);
2787 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2789 Tcl_DStringAppend (&text_cmd_2
, " insert end { \t", -1);
2790 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2792 while (fgets (line
+ 1, 980, fp
))
2794 sprintf (line_num_buf
, "%d", ln
);
2795 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2797 cur_cmd
= &text_cmd_1
;
2798 cur_prefix_len
= prefix_len_1
;
2799 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2800 Tcl_DStringAppend (cur_cmd
, "} break_rgn_tag", 15);
2804 cur_cmd
= &text_cmd_2
;
2805 cur_prefix_len
= prefix_len_2
;
2806 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2807 Tcl_DStringAppend (cur_cmd
, "} \"\"", 4);
2810 Tcl_DStringAppendElement (cur_cmd
, line
);
2811 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2813 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2814 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2820 Tcl_DStringAppend (&text_cmd_1
, " insert end {- } break_rgn_tag", -1);
2821 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2822 Tcl_DStringAppend (&text_cmd_2
, " insert end { } \"\"", -1);
2823 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2825 while (fgets (line
+ 1, 980, fp
))
2827 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2829 cur_cmd
= &text_cmd_1
;
2830 cur_prefix_len
= prefix_len_1
;
2834 cur_cmd
= &text_cmd_2
;
2835 cur_prefix_len
= prefix_len_2
;
2838 Tcl_DStringAppendElement (cur_cmd
, line
);
2839 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2841 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2842 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2848 Tcl_DStringFree (&text_cmd_1
);
2849 Tcl_DStringFree (&text_cmd_2
);
2856 * This section contains commands for manipulation of breakpoints.
2860 /* set a breakpoint by source file and line number */
2861 /* flags are as follows: */
2862 /* least significant 2 bits are disposition, rest is */
2863 /* type (normally 0).
2866 bp_breakpoint, Normal breakpoint
2867 bp_hardware_breakpoint, Hardware assisted breakpoint
2870 Disposition of breakpoint. Ie: what to do after hitting it.
2873 del_at_next_stop, Delete at next stop, whether hit or not
2875 donttouch Leave it alone
2879 /* This implements the tcl command "gdb_set_bp"
2880 * It sets breakpoints, and runs the Tcl command
2881 * gdbtk_tcl_breakpoint create
2882 * to register the new breakpoint with the GUI.
2885 * filename: the file in which to set the breakpoint
2886 * line: the line number for the breakpoint
2887 * type: the type of the breakpoint
2888 * thread: optional thread number
2890 * The return value of the call to gdbtk_tcl_breakpoint.
2894 gdb_set_bp (clientData
, interp
, objc
, objv
)
2895 ClientData clientData
;
2898 Tcl_Obj
*CONST objv
[];
2901 struct symtab_and_line sal
;
2902 int line
, flags
, ret
, thread
= -1;
2903 struct breakpoint
*b
;
2907 if (objc
!= 4 && objc
!= 5)
2909 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type [thread]");
2913 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
2914 if (sal
.symtab
== NULL
)
2917 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
2919 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2923 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
2925 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2931 if (Tcl_GetIntFromObj( interp
, objv
[4], &thread
) == TCL_ERROR
)
2933 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2939 if (!find_line_pc (sal
.symtab
, sal
.line
, &sal
.pc
))
2942 sal
.section
= find_pc_overlay (sal
.pc
);
2943 b
= set_raw_breakpoint (sal
);
2944 set_breakpoint_count (breakpoint_count
+ 1);
2945 b
->number
= breakpoint_count
;
2946 b
->type
= flags
>> 2;
2947 b
->disposition
= flags
& 3;
2950 /* FIXME: this won't work for duplicate basenames! */
2951 sprintf (buf
, "%s:%d", basename (Tcl_GetStringFromObj ( objv
[1], NULL
)), line
);
2952 b
->addr_string
= strsave (buf
);
2954 /* now send notification command back to GUI */
2956 Tcl_DStringInit (&cmd
);
2958 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2959 sprintf (buf
, "%d", b
->number
);
2960 Tcl_DStringAppendElement(&cmd
, buf
);
2961 sprintf (buf
, "0x%lx", (long)sal
.pc
);
2962 Tcl_DStringAppendElement (&cmd
, buf
);
2963 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[2], NULL
));
2964 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[1], NULL
));
2965 Tcl_DStringAppendElement (&cmd
, bpdisp
[b
->disposition
]);
2966 sprintf (buf
, "%d", b
->enable
);
2967 Tcl_DStringAppendElement (&cmd
, buf
);
2968 sprintf (buf
, "%d", b
->thread
);
2969 Tcl_DStringAppendElement (&cmd
, buf
);
2972 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2973 Tcl_DStringFree (&cmd
);
2977 /* This implements the tcl command "gdb_set_bp_addr"
2978 * It sets breakpoints, and runs the Tcl command
2979 * gdbtk_tcl_breakpoint create
2980 * to register the new breakpoint with the GUI.
2983 * addr: the address at which to set the breakpoint
2984 * type: the type of the breakpoint
2985 * thread: optional thread number
2987 * The return value of the call to gdbtk_tcl_breakpoint.
2991 gdb_set_bp_addr (clientData
, interp
, objc
, objv
)
2992 ClientData clientData
;
2995 Tcl_Obj
*CONST objv
[];
2998 struct symtab_and_line sal
;
2999 int line
, flags
, ret
, thread
= -1;
3001 struct breakpoint
*b
;
3002 char *filename
, buf
[64];
3005 if (objc
!= 4 && objc
!= 3)
3007 Tcl_WrongNumArgs(interp
, 1, objv
, "addr type ?thread?");
3011 if (Tcl_GetLongFromObj( interp
, objv
[1], &addr
) == TCL_ERROR
)
3013 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3017 if (Tcl_GetIntFromObj( interp
, objv
[2], &flags
) == TCL_ERROR
)
3019 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3025 if (Tcl_GetIntFromObj( interp
, objv
[3], &thread
) == TCL_ERROR
)
3027 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3032 sal
= find_pc_line (addr
, 0);
3034 b
= set_raw_breakpoint (sal
);
3035 set_breakpoint_count (breakpoint_count
+ 1);
3036 b
->number
= breakpoint_count
;
3037 b
->type
= flags
>> 2;
3038 b
->disposition
= flags
& 3;
3041 sprintf (buf
, "*(0x%lx)",addr
);
3042 b
->addr_string
= strsave (buf
);
3044 /* now send notification command back to GUI */
3046 Tcl_DStringInit (&cmd
);
3048 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
3049 sprintf (buf
, "%d", b
->number
);
3050 Tcl_DStringAppendElement(&cmd
, buf
);
3051 sprintf (buf
, "0x%lx", addr
);
3052 Tcl_DStringAppendElement (&cmd
, buf
);
3053 sprintf (buf
, "%d", b
->line_number
);
3054 Tcl_DStringAppendElement (&cmd
, buf
);
3056 filename
= symtab_to_filename (sal
.symtab
);
3057 if (filename
== NULL
)
3059 Tcl_DStringAppendElement (&cmd
, filename
);
3060 Tcl_DStringAppendElement (&cmd
, bpdisp
[b
->disposition
]);
3061 sprintf (buf
, "%d", b
->enable
);
3062 Tcl_DStringAppendElement (&cmd
, buf
);
3063 sprintf (buf
, "%d", b
->thread
);
3064 Tcl_DStringAppendElement (&cmd
, buf
);
3066 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
3067 Tcl_DStringFree (&cmd
);
3071 /* This implements the tcl command "gdb_find_bp_at_line"
3074 * filename: the file in which to find the breakpoint
3075 * line: the line number for the breakpoint
3077 * It returns a list of breakpoint numbers
3081 gdb_find_bp_at_line(clientData
, interp
, objc
, objv
)
3082 ClientData clientData
;
3085 Tcl_Obj
*CONST objv
[];
3090 struct breakpoint
*b
;
3091 extern struct breakpoint
*breakpoint_chain
;
3095 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line");
3099 s
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
3103 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
3105 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3109 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3110 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3111 if (b
->line_number
== line
&& !strcmp(b
->source_file
, s
->filename
))
3112 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3113 Tcl_NewIntObj (b
->number
));
3119 /* This implements the tcl command "gdb_find_bp_at_addr"
3124 * It returns a list of breakpoint numbers
3128 gdb_find_bp_at_addr(clientData
, interp
, objc
, objv
)
3129 ClientData clientData
;
3132 Tcl_Obj
*CONST objv
[];
3136 struct breakpoint
*b
;
3137 extern struct breakpoint
*breakpoint_chain
;
3141 Tcl_WrongNumArgs(interp
, 1, objv
, "address");
3145 if (Tcl_GetLongFromObj( interp
, objv
[1], &addr
) == TCL_ERROR
)
3147 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3151 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3152 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3153 if (b
->address
== (CORE_ADDR
)addr
)
3154 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3155 Tcl_NewIntObj (b
->number
));
3160 /* This implements the tcl command gdb_get_breakpoint_info
3166 * A list with {file, function, line_number, address, type, enabled?,
3167 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
3171 gdb_get_breakpoint_info (clientData
, interp
, objc
, objv
)
3172 ClientData clientData
;
3175 Tcl_Obj
*CONST objv
[];
3177 struct symtab_and_line sal
;
3178 struct command_line
*cmd
;
3180 struct breakpoint
*b
;
3181 extern struct breakpoint
*breakpoint_chain
;
3182 char *funcname
, *fname
, *filename
;
3187 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong number of args, should be \"breakpoint\"", -1);
3191 if ( Tcl_GetIntFromObj(NULL
, objv
[1], &bpnum
) != TCL_OK
)
3193 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3197 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3198 if (b
->number
== bpnum
)
3201 if (!b
|| b
->type
!= bp_breakpoint
)
3204 sprintf(err_buf
, "Breakpoint #%d does not exist.", bpnum
);
3205 Tcl_SetStringObj (result_ptr
->obj_ptr
, err_buf
, -1);
3209 sal
= find_pc_line (b
->address
, 0);
3211 filename
= symtab_to_filename (sal
.symtab
);
3212 if (filename
== NULL
)
3215 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3216 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3217 Tcl_NewStringObj (filename
, -1));
3219 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
3220 fname
= cplus_demangle (funcname
, 0);
3223 new_obj
= Tcl_NewStringObj (fname
, -1);
3227 new_obj
= Tcl_NewStringObj (funcname
, -1);
3229 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
3231 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->line_number
));
3232 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%lx", b
->address
);
3233 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3234 Tcl_NewStringObj (bptypes
[b
->type
], -1));
3235 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewBooleanObj(b
->enable
== enabled
));
3236 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3237 Tcl_NewStringObj (bpdisp
[b
->disposition
], -1));
3238 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->ignore_count
));
3240 new_obj
= Tcl_NewObj();
3241 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
3242 Tcl_ListObjAppendElement (NULL
, new_obj
,
3243 Tcl_NewStringObj (cmd
->line
, -1));
3244 Tcl_ListObjAppendElement(NULL
, result_ptr
->obj_ptr
, new_obj
);
3246 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3247 Tcl_NewStringObj (b
->cond_string
, -1));
3249 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->thread
));
3250 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->hit_count
));
3256 /* This implements the tcl command gdb_get_breakpoint_list
3257 * It builds up a list of the current breakpoints.
3262 * A list of breakpoint numbers.
3266 gdb_get_breakpoint_list (clientData
, interp
, objc
, objv
)
3267 ClientData clientData
;
3270 Tcl_Obj
*CONST objv
[];
3272 struct breakpoint
*b
;
3273 extern struct breakpoint
*breakpoint_chain
;
3277 error ("wrong number of args, none are allowed");
3279 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3280 if (b
->type
== bp_breakpoint
)
3282 new_obj
= Tcl_NewIntObj (b
->number
);
3283 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
3289 /* The functions in this section deal with stacks and backtraces. */
3291 /* This implements the tcl command gdb_stack.
3292 * It builds up a list of stack frames.
3295 * start - starting stack frame
3296 * count - number of frames to inspect
3298 * A list of function names
3302 gdb_stack (clientData
, interp
, objc
, objv
) ClientData clientData
;
3305 Tcl_Obj
*CONST objv
[];
3311 Tcl_WrongNumArgs (interp
, 1, objv
, "start count");
3312 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3316 if (Tcl_GetIntFromObj (NULL
, objv
[1], &start
))
3318 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3321 if (Tcl_GetIntFromObj (NULL
, objv
[2], &count
))
3323 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3327 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
3329 if (target_has_stack
)
3331 struct frame_info
*top
;
3332 struct frame_info
*fi
;
3334 /* Find the outermost frame */
3335 fi
= get_current_frame ();
3339 fi
= get_prev_frame (fi
);
3342 /* top now points to the top (outermost frame) of the
3343 stack, so point it to the requested start */
3345 top
= find_relative_frame (top
, &start
);
3347 /* If start != 0, then we have asked to start outputting
3348 frames beyond the innermost stack frame */
3352 while (fi
&& count
--)
3354 get_frame_name (interp
, result_ptr
->obj_ptr
, fi
);
3355 fi
= get_next_frame (fi
);
3363 /* A helper function for get_stack which adds information about
3364 * the stack frame FI to the caller's LIST.
3366 * This is stolen from print_frame_info in stack.c.
3369 get_frame_name (interp
, list
, fi
)
3372 struct frame_info
*fi
;
3374 struct symtab_and_line sal
;
3375 struct symbol
*func
= NULL
;
3376 register char *funname
= 0;
3377 enum language funlang
= language_unknown
;
3380 if (frame_in_dummy (fi
))
3382 objv
[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
3383 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3386 if (fi
->signal_handler_caller
)
3388 objv
[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
3389 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3394 find_pc_line (fi
->pc
,
3396 && !fi
->next
->signal_handler_caller
3397 && !frame_in_dummy (fi
->next
));
3399 func
= find_pc_function (fi
->pc
);
3402 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3404 && (SYMBOL_VALUE_ADDRESS (msymbol
)
3405 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
3408 funname
= GDBTK_SYMBOL_SOURCE_NAME (msymbol
);
3409 funlang
= SYMBOL_LANGUAGE (msymbol
);
3413 funname
= GDBTK_SYMBOL_SOURCE_NAME (func
);
3414 funlang
= SYMBOL_LANGUAGE (func
);
3419 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3420 if (msymbol
!= NULL
)
3422 funname
= GDBTK_SYMBOL_SOURCE_NAME (msymbol
);
3423 funlang
= SYMBOL_LANGUAGE (msymbol
);
3431 objv
[0] = Tcl_NewStringObj (funname
, -1);
3432 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3437 /* we have no convenient way to deal with this yet... */
3438 if (fi
->pc
!= sal
.pc
|| !sal
.symtab
)
3440 print_address_numeric (fi
->pc
, 1, gdb_stdout
);
3441 printf_filtered (" in ");
3443 printf_symbol_filtered (gdb_stdout
, funname
? funname
: "??", funlang
,
3446 objv
[0] = Tcl_NewStringObj (funname
!= NULL
? funname
: "??", -1);
3447 #ifdef PC_LOAD_SEGMENT
3448 /* If we couldn't print out function name but if can figure out what
3449 load segment this pc value is from, at least print out some info
3450 about its load segment. */
3453 Tcl_AppendStringsToObj (objv
[0], " from ", PC_LOAD_SEGMENT (fi
->pc
),
3460 char *lib
= PC_SOLIB (fi
->pc
);
3463 Tcl_AppendStringsToObj (objv
[0], " from ", lib
, (char *) NULL
);
3467 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3473 * This section contains a bunch of miscellaneous utility commands
3476 /* This implements the tcl command gdb_path_conv
3478 * On Windows, it canonicalizes the pathname,
3479 * On Unix, it is a no op.
3484 * The canonicalized path.
3488 gdb_path_conv (clientData
, interp
, objc
, objv
)
3489 ClientData clientData
;
3492 Tcl_Obj
*CONST objv
[];
3495 error ("wrong # args");
3499 char pathname
[256], *ptr
;
3501 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj (objv
[1], NULL
), pathname
);
3502 for (ptr
= pathname
; *ptr
; ptr
++)
3507 Tcl_SetStringObj (result_ptr
->obj_ptr
, pathname
, -1);
3510 Tcl_SetStringObj (result_ptr
->obj_ptr
, Tcl_GetStringFromObj (objv
[1], NULL
), -1);
3517 * This section has utility routines that are not Tcl commands.
3521 perror_with_name_wrapper (args
)
3524 perror_with_name (args
);
3528 /* The lookup_symtab() in symtab.c doesn't work correctly */
3529 /* It will not work will full pathnames and if multiple */
3530 /* source files have the same basename, it will return */
3531 /* the first one instead of the correct one. This version */
3532 /* also always makes sure symtab->fullname is set. */
3534 static struct symtab
*
3535 full_lookup_symtab(file
)
3539 struct objfile
*objfile
;
3540 char *bfile
, *fullname
;
3541 struct partial_symtab
*pt
;
3546 /* first try a direct lookup */
3547 st
= lookup_symtab (file
);
3551 symtab_to_filename(st
);
3555 /* if the direct approach failed, try */
3556 /* looking up the basename and checking */
3557 /* all matches with the fullname */
3558 bfile
= basename (file
);
3559 ALL_SYMTABS (objfile
, st
)
3561 if (!strcmp (bfile
, basename(st
->filename
)))
3564 fullname
= symtab_to_filename (st
);
3566 fullname
= st
->fullname
;
3568 if (!strcmp (file
, fullname
))
3573 /* still no luck? look at psymtabs */
3574 ALL_PSYMTABS (objfile
, pt
)
3576 if (!strcmp (bfile
, basename(pt
->filename
)))
3578 st
= PSYMTAB_TO_SYMTAB (pt
);
3581 fullname
= symtab_to_filename (st
);
3582 if (!strcmp (file
, fullname
))
3590 /* Local variables: */
3591 /* change-log-default-name: "ChangeLog-gdbtk" */