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
[] = {"none", "breakpoint", "hw breakpoint", "until",
139 "finish", "watchpoint", "hw watchpoint",
140 "read watchpoint", "acc watchpoint",
141 "longjmp", "longjmp resume", "step resume",
142 "sigtramp", "watchpoint scope",
143 "call dummy", "shlib events", "catch load",
144 "catch unload", "catch fork", "catch vfork",
145 "catch exec", "catch catch", "catch throw"
147 char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
150 * These are routines we need from breakpoint.c.
151 * at some point make these static in breakpoint.c and move GUI code there
154 extern struct breakpoint
*set_raw_breakpoint (struct symtab_and_line sal
);
155 extern void set_breakpoint_count (int);
156 extern int breakpoint_count
;
158 /* This variable determines where memory used for disassembly is read from.
159 * See note in gdbtk.h for details.
161 int disassemble_from_exec
= -1;
163 extern int gdb_variable_init
PARAMS ((Tcl_Interp
*interp
));
166 * Declarations for routines exported from this file
169 int Gdbtk_Init (Tcl_Interp
*interp
);
170 int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
173 * Declarations for routines used only in this file.
176 static int compare_lines
PARAMS ((const PTR
, const PTR
));
177 static int comp_files
PARAMS ((const void *, const void *));
178 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
179 Tcl_Obj
*CONST objv
[]));
180 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
181 static int gdb_clear_file
PARAMS ((ClientData
, Tcl_Interp
*interp
, int, Tcl_Obj
*CONST
[]));
182 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
183 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
184 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int,
186 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
187 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
188 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
189 Tcl_Obj
*CONST objv
[]));
190 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
191 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
192 static int gdb_get_args_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
193 Tcl_Obj
*CONST objv
[]));
194 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
195 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
196 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
197 Tcl_Obj
*CONST objv
[]));
198 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
199 Tcl_Obj
*CONST objv
[]));
200 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
201 Tcl_Obj
*CONST objv
[]));
202 static int gdb_get_locals_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
203 Tcl_Obj
*CONST objv
[]));
204 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
205 static int gdb_get_trace_frame_num
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
206 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int,
207 Tcl_Obj
*CONST objv
[]));
208 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
209 Tcl_Obj
*CONST objv
[]));
210 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
211 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
212 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
213 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
214 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
215 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
216 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
217 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
218 Tcl_Obj
*CONST objv
[]));
219 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
220 static int gdb_search
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
222 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
223 static int gdb_set_bp_addr
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
224 static int gdb_find_bp_at_line
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
225 static int gdb_find_bp_at_addr
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
226 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
227 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*,
230 static int gdb_trace_status
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
231 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*,
233 Tcl_Obj
*CONST objv
[]));
234 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int,
235 Tcl_Obj
*CONST objv
[]));
236 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
237 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
238 static int gdb_stack
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
240 char * get_prompt
PARAMS ((void));
241 static void get_register
PARAMS ((int, void *));
242 static void get_register_name
PARAMS ((int, void *));
243 static int map_arg_registers
PARAMS ((int, Tcl_Obj
*CONST
[], void (*) (int, void *), void *));
244 static int perror_with_name_wrapper
PARAMS ((char *args
));
245 static void register_changed_p
PARAMS ((int, void *));
246 void TclDebug
PARAMS ((const char *fmt
, ...));
247 static int wrapped_call (char *opaque_args
);
248 static void get_frame_name
PARAMS ((Tcl_Interp
*interp
, Tcl_Obj
*list
, struct frame_info
*fi
));
251 * This loads all the Tcl commands into the Tcl interpreter.
254 * interp - The interpreter into which to load the commands.
257 * A standard Tcl result.
264 Tcl_CreateObjCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
265 Tcl_CreateObjCommand (interp
, "gdb_immediate", call_wrapper
,
266 gdb_immediate_command
, NULL
);
267 Tcl_CreateObjCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
268 Tcl_CreateObjCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
269 Tcl_CreateObjCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
, NULL
);
270 Tcl_CreateObjCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
272 Tcl_CreateObjCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
274 Tcl_CreateObjCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
275 Tcl_CreateObjCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
276 Tcl_CreateObjCommand (interp
, "gdb_fetch_registers", call_wrapper
,
277 gdb_fetch_registers
, NULL
);
278 Tcl_CreateObjCommand (interp
, "gdb_changed_register_list", call_wrapper
,
279 gdb_changed_register_list
, NULL
);
280 Tcl_CreateObjCommand (interp
, "gdb_disassemble", call_wrapper
,
281 gdb_disassemble
, NULL
);
282 Tcl_CreateObjCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
283 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
284 gdb_get_breakpoint_list
, NULL
);
285 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
286 gdb_get_breakpoint_info
, NULL
);
287 Tcl_CreateObjCommand (interp
, "gdb_clear_file", call_wrapper
,
288 gdb_clear_file
, NULL
);
289 Tcl_CreateObjCommand (interp
, "gdb_confirm_quit", call_wrapper
,
290 gdb_confirm_quit
, NULL
);
291 Tcl_CreateObjCommand (interp
, "gdb_force_quit", call_wrapper
,
292 gdb_force_quit
, NULL
);
293 Tcl_CreateObjCommand (interp
, "gdb_target_has_execution",
295 gdb_target_has_execution_command
, NULL
);
296 Tcl_CreateObjCommand (interp
, "gdb_is_tracing",
297 call_wrapper
, gdb_trace_status
,
299 Tcl_CreateObjCommand (interp
, "gdb_load_info", call_wrapper
, gdb_load_info
, NULL
);
300 Tcl_CreateObjCommand (interp
, "gdb_get_locals", call_wrapper
, gdb_get_locals_command
,
302 Tcl_CreateObjCommand (interp
, "gdb_get_args", call_wrapper
, gdb_get_args_command
,
304 Tcl_CreateObjCommand (interp
, "gdb_get_function", call_wrapper
, gdb_get_function_command
,
306 Tcl_CreateObjCommand (interp
, "gdb_get_line", call_wrapper
, gdb_get_line_command
,
308 Tcl_CreateObjCommand (interp
, "gdb_get_file", call_wrapper
, gdb_get_file_command
,
310 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
311 call_wrapper
, gdb_tracepoint_exists_command
, NULL
);
312 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
313 call_wrapper
, gdb_get_tracepoint_info
, NULL
);
314 Tcl_CreateObjCommand (interp
, "gdb_actions",
315 call_wrapper
, gdb_actions_command
, NULL
);
316 Tcl_CreateObjCommand (interp
, "gdb_prompt",
317 call_wrapper
, gdb_prompt_command
, NULL
);
318 Tcl_CreateObjCommand (interp
, "gdb_find_file",
319 call_wrapper
, gdb_find_file_command
, NULL
);
320 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
321 call_wrapper
, gdb_get_tracepoint_list
, NULL
);
322 Tcl_CreateObjCommand (interp
, "gdb_pc_reg", call_wrapper
, get_pc_register
, NULL
);
323 Tcl_CreateObjCommand (interp
, "gdb_loadfile", call_wrapper
, gdb_loadfile
, NULL
);
324 Tcl_CreateObjCommand (gdbtk_interp
, "gdb_search", call_wrapper
,
326 Tcl_CreateObjCommand (interp
, "gdb_set_bp", call_wrapper
, gdb_set_bp
, NULL
);
327 Tcl_CreateObjCommand (interp
, "gdb_set_bp_addr", call_wrapper
, gdb_set_bp_addr
, NULL
);
328 Tcl_CreateObjCommand (interp
, "gdb_find_bp_at_line", call_wrapper
, gdb_find_bp_at_line
, NULL
);
329 Tcl_CreateObjCommand (interp
, "gdb_find_bp_at_addr", call_wrapper
, gdb_find_bp_at_addr
, NULL
);
330 Tcl_CreateObjCommand (interp
, "gdb_get_trace_frame_num",
331 call_wrapper
, gdb_get_trace_frame_num
, NULL
);
332 Tcl_CreateObjCommand (interp
, "gdb_stack", call_wrapper
, gdb_stack
, NULL
);
334 Tcl_LinkVar (interp
, "gdb_selected_frame_level",
335 (char *) &selected_frame_level
,
336 TCL_LINK_INT
| TCL_LINK_READ_ONLY
);
338 /* gdb_context is used for debugging multiple threads or tasks */
339 Tcl_LinkVar (interp
, "gdb_context_id",
340 (char *) &gdb_context
,
341 TCL_LINK_INT
| TCL_LINK_READ_ONLY
);
343 /* Init variable interface...*/
344 if (gdb_variable_init (interp
) != TCL_OK
)
347 /* Determine where to disassemble from */
348 Tcl_LinkVar (gdbtk_interp
, "disassemble-from-exec", (char *) &disassemble_from_exec
,
351 Tcl_PkgProvide(interp
, "Gdbtk", GDBTK_VERSION
);
355 /* This routine acts as a top-level for all GDB code called by Tcl/Tk. It
356 handles cleanups, and uses catch_errors to trap calls to return_to_top_level
358 This is necessary in order to prevent a longjmp out of the bowels of Tk,
359 possibly leaving things in a bad state. Since this routine can be called
360 recursively, it needs to save and restore the contents of the result_ptr as
364 call_wrapper (clientData
, interp
, objc
, objv
)
365 ClientData clientData
;
368 Tcl_Obj
*CONST objv
[];
370 struct wrapped_call_args wrapped_args
;
371 gdbtk_result new_result
, *old_result_ptr
;
373 old_result_ptr
= result_ptr
;
374 result_ptr
= &new_result
;
375 result_ptr
->obj_ptr
= Tcl_NewObj();
376 result_ptr
->flags
= GDBTK_TO_RESULT
;
378 wrapped_args
.func
= (Tcl_ObjCmdProc
*) clientData
;
379 wrapped_args
.interp
= interp
;
380 wrapped_args
.objc
= objc
;
381 wrapped_args
.objv
= objv
;
382 wrapped_args
.val
= TCL_OK
;
384 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
387 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
389 /* Make sure the timer interrupts are turned off. */
393 gdb_flush (gdb_stderr
); /* Flush error output */
394 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
396 /* If we errored out here, and the results were going to the
397 console, then gdbtk_fputs will have gathered the result into the
398 result_ptr. We also need to echo them out to the console here */
400 gdb_flush (gdb_stderr
); /* Flush error output */
401 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
403 /* In case of an error, we may need to force the GUI into idle
404 mode because gdbtk_call_command may have bombed out while in
405 the command routine. */
408 Tcl_Eval (interp
, "gdbtk_tcl_idle");
412 /* do not suppress any errors -- a remote target could have errored */
413 load_in_progress
= 0;
416 * Now copy the result over to the true Tcl result. If GDBTK_TO_RESULT flag
417 * bit is set , this just copies a null object over to the Tcl result, which is
418 * fine because we should reset the result in this case anyway.
420 if (result_ptr
->flags
& GDBTK_IN_TCL_RESULT
)
422 Tcl_DecrRefCount(result_ptr
->obj_ptr
);
426 Tcl_SetObjResult (interp
, result_ptr
->obj_ptr
);
429 result_ptr
= old_result_ptr
;
435 return wrapped_args
.val
;
439 * This is the wrapper that is passed to catch_errors.
443 wrapped_call (opaque_args
)
446 struct wrapped_call_args
*args
= (struct wrapped_call_args
*) opaque_args
;
447 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->objc
, args
->objv
);
451 /* This is a convenience function to sprintf something(s) into a
452 * new element in a Tcl list object.
456 #ifdef ANSI_PROTOTYPES
457 sprintf_append_element_to_obj (Tcl_Obj
*objp
, char *format
, ...)
459 sprintf_append_element_to_obj (va_alist
)
466 #ifdef ANSI_PROTOTYPES
467 va_start (args
, format
);
473 dsp
= va_arg (args
, Tcl_Obj
*);
474 format
= va_arg (args
, char *);
477 vsprintf (buf
, format
, args
);
479 Tcl_ListObjAppendElement (NULL
, objp
, Tcl_NewStringObj (buf
, -1));
483 * This section contains the commands that control execution.
486 /* This implements the tcl command gdb_clear_file.
488 * Prepare to accept a new executable file. This is called when we
489 * want to clear away everything we know about the old file, without
490 * asking the user. The Tcl code will have already asked the user if
491 * necessary. After this is called, we should be able to run the
492 * `file' command without getting any questions.
501 gdb_clear_file (clientData
, interp
, objc
, objv
)
502 ClientData clientData
;
505 Tcl_Obj
*CONST objv
[];
508 Tcl_SetStringObj (result_ptr
->obj_ptr
,
509 "Wrong number of args, none are allowed.", -1);
511 if (inferior_pid
!= 0 && target_has_execution
)
514 target_detach (NULL
, 0);
519 if (target_has_execution
)
522 symbol_file_command (NULL
, 0);
524 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
525 clear it here. FIXME: This seems like an abstraction violation
532 /* This implements the tcl command gdb_confirm_quit
533 * Ask the user to confirm an exit request.
538 * A boolean, 1 if the user answered yes, 0 if no.
542 gdb_confirm_quit (clientData
, interp
, objc
, objv
)
543 ClientData clientData
;
546 Tcl_Obj
*CONST objv
[];
552 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
556 ret
= quit_confirm ();
557 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, ret
);
561 /* This implements the tcl command gdb_force_quit
562 * Quit without asking for confirmation.
571 gdb_force_quit (clientData
, interp
, objc
, objv
)
572 ClientData clientData
;
575 Tcl_Obj
*CONST objv
[];
579 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
583 quit_force ((char *) NULL
, 1);
587 /* This implements the tcl command gdb_stop
588 * It stops the target in a continuable fashion.
597 gdb_stop (clientData
, interp
, objc
, objv
)
598 ClientData clientData
;
601 Tcl_Obj
*CONST objv
[];
603 if (target_stop
!= target_ignore
)
606 quit_flag
= 1; /* hope something sees this */
613 * This section contains Tcl commands that are wrappers for invoking
614 * the GDB command interpreter.
618 /* This implements the tcl command `gdb_eval'.
619 * It uses the gdb evaluator to return the value of
620 * an expression in the current language
623 * expression - the expression to evaluate.
625 * The result of the evaluation.
629 gdb_eval (clientData
, interp
, objc
, objv
)
630 ClientData clientData
;
633 Tcl_Obj
*CONST objv
[];
635 struct expression
*expr
;
636 struct cleanup
*old_chain
=NULL
;
641 Tcl_SetStringObj (result_ptr
->obj_ptr
,
642 "wrong # args, should be \"gdb_eval expression\"", -1);
646 expr
= parse_expression (Tcl_GetStringFromObj (objv
[1], NULL
));
648 old_chain
= make_cleanup ((make_cleanup_func
) free_current_contents
, &expr
);
650 val
= evaluate_expression (expr
);
653 * Print the result of the expression evaluation. This will go to
654 * eventually go to gdbtk_fputs, and from there be collected into
658 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
),
659 VALUE_EMBEDDED_OFFSET(val
), VALUE_ADDRESS (val
),
660 gdb_stdout
, 0, 0, 0, 0);
662 do_cleanups (old_chain
);
667 /* This implements the tcl command "gdb_cmd".
669 * It sends its argument to the GDB command scanner for execution.
670 * This command will never cause the update, idle and busy hooks to be called
674 * command - The GDB command to execute
675 * from_tty - 1 indicates this comes to the console. Pass this to the gdb command.
677 * The output from the gdb command (except for the "load" & "while"
678 * which dump their output to the console.
682 gdb_cmd (clientData
, interp
, objc
, objv
)
683 ClientData clientData
;
686 Tcl_Obj
*CONST objv
[];
692 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
698 if (Tcl_GetBooleanFromObj (NULL
, objv
[2], &from_tty
) != TCL_OK
) {
699 Tcl_SetStringObj (result_ptr
->obj_ptr
, "from_tty must be a boolean.",
705 if (running_now
|| load_in_progress
)
710 /* for the load instruction (and possibly others later) we
711 set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
712 will not buffer all the data until the command is finished. */
714 if ((strncmp ("load ", Tcl_GetStringFromObj (objv
[1], NULL
), 5) == 0))
716 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
717 load_in_progress
= 1;
720 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), from_tty
);
722 if (load_in_progress
)
724 load_in_progress
= 0;
725 result_ptr
->flags
|= GDBTK_TO_RESULT
;
728 bpstat_do_actions (&stop_bpstat
);
734 * This implements the tcl command "gdb_immediate"
736 * It does exactly the same thing as gdb_cmd, except NONE of its outut
737 * is buffered. This will also ALWAYS cause the busy, update, and idle hooks to
738 * be called, contrasted with gdb_cmd, which NEVER calls them.
739 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
740 * to the console window.
743 * command - The GDB command to execute
744 * from_tty - 1 to indicate this is from the console.
750 gdb_immediate_command (clientData
, interp
, objc
, objv
)
751 ClientData clientData
;
754 Tcl_Obj
*CONST objv
[];
761 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
767 if (Tcl_GetBooleanFromObj (NULL
, objv
[2], &from_tty
) != TCL_OK
) {
768 Tcl_SetStringObj (result_ptr
->obj_ptr
, "from_tty must be a boolean.",
774 if (running_now
|| load_in_progress
)
779 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
781 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), from_tty
);
783 bpstat_do_actions (&stop_bpstat
);
785 result_ptr
->flags
|= GDBTK_TO_RESULT
;
790 /* This implements the tcl command "gdb_prompt"
792 * It returns the gdb interpreter's prompt.
801 gdb_prompt_command (clientData
, interp
, objc
, objv
)
802 ClientData clientData
;
805 Tcl_Obj
*CONST objv
[];
807 Tcl_SetStringObj (result_ptr
->obj_ptr
, get_prompt (), -1);
813 * This section contains general informational commands.
816 /* This implements the tcl command "gdb_target_has_execution"
818 * Tells whether the target is executing.
823 * A boolean indicating whether the target is executing.
827 gdb_target_has_execution_command (clientData
, interp
, objc
, objv
)
828 ClientData clientData
;
831 Tcl_Obj
*CONST objv
[];
835 if (target_has_execution
&& inferior_pid
!= 0)
838 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, result
);
842 /* This implements the tcl command "gdb_load_info"
844 * It returns information about the file about to be downloaded.
847 * filename: The file to open & get the info on.
849 * A list consisting of the name and size of each section.
853 gdb_load_info (clientData
, interp
, objc
, objv
)
854 ClientData clientData
;
857 Tcl_Obj
*CONST objv
[];
860 struct cleanup
*old_cleanups
;
864 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
866 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
867 if (loadfile_bfd
== NULL
)
869 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Open failed", -1);
872 old_cleanups
= make_cleanup ((make_cleanup_func
) bfd_close
, loadfile_bfd
);
874 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
876 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Bad Object File", -1);
880 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
882 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
884 if (s
->flags
& SEC_LOAD
)
886 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
889 ob
[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd
, s
), -1);
890 ob
[1] = Tcl_NewLongObj ((long) size
);
891 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewListObj (2, ob
));
896 do_cleanups (old_cleanups
);
902 * This and gdb_get_locals just call gdb_get_vars_command with the right
903 * value of clientData. We can't use the client data in the definition
904 * of the command, because the call wrapper uses this instead...
908 gdb_get_locals_command (clientData
, interp
, objc
, objv
)
909 ClientData clientData
;
912 Tcl_Obj
*CONST objv
[];
915 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
920 gdb_get_args_command (clientData
, interp
, objc
, objv
)
921 ClientData clientData
;
924 Tcl_Obj
*CONST objv
[];
927 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
931 /* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
933 * This function sets the Tcl interpreter's result to a list of variable names
934 * depending on clientData. If clientData is one, the result is a list of
935 * arguments; zero returns a list of locals -- all relative to the block
936 * specified as an argument to the command. Valid commands include
937 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
941 * block - the address within which to specify the locals or args.
943 * A list of the locals or args
947 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
948 ClientData clientData
;
951 Tcl_Obj
*CONST objv
[];
953 struct symtabs_and_lines sals
;
956 char **canonical
, *args
;
957 int i
, nsyms
, arguments
;
961 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
,
962 "wrong # of args: should be \"",
963 Tcl_GetStringFromObj (objv
[0], NULL
),
964 " function:line|function|line|*addr\"", NULL
);
968 arguments
= (int) clientData
;
969 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
970 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
973 Tcl_SetStringObj (result_ptr
->obj_ptr
,
974 "error decoding line", -1);
978 /* Initialize the result pointer to an empty list. */
980 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
982 /* Resolve all line numbers to PC's */
983 for (i
= 0; i
< sals
.nelts
; i
++)
984 resolve_sal_pc (&sals
.sals
[i
]);
986 block
= block_for_pc (sals
.sals
[0].pc
);
989 nsyms
= BLOCK_NSYMS (block
);
990 for (i
= 0; i
< nsyms
; i
++)
992 sym
= BLOCK_SYM (block
, i
);
993 switch (SYMBOL_CLASS (sym
)) {
995 case LOC_UNDEF
: /* catches errors */
996 case LOC_CONST
: /* constant */
997 case LOC_TYPEDEF
: /* local typedef */
998 case LOC_LABEL
: /* local label */
999 case LOC_BLOCK
: /* local function */
1000 case LOC_CONST_BYTES
: /* loc. byte seq. */
1001 case LOC_UNRESOLVED
: /* unresolved static */
1002 case LOC_OPTIMIZED_OUT
: /* optimized out */
1004 case LOC_ARG
: /* argument */
1005 case LOC_REF_ARG
: /* reference arg */
1006 case LOC_REGPARM
: /* register arg */
1007 case LOC_REGPARM_ADDR
: /* indirect register arg */
1008 case LOC_LOCAL_ARG
: /* stack arg */
1009 case LOC_BASEREG_ARG
: /* basereg arg */
1011 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1012 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
1014 case LOC_LOCAL
: /* stack local */
1015 case LOC_BASEREG
: /* basereg local */
1016 case LOC_STATIC
: /* static */
1017 case LOC_REGISTER
: /* register */
1019 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1020 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
1024 if (BLOCK_FUNCTION (block
))
1027 block
= BLOCK_SUPERBLOCK (block
);
1033 /* This implements the tcl command "gdb_get_line"
1035 * It returns the linenumber for a given linespec. It will take any spec
1036 * that can be passed to decode_line_1
1039 * linespec - the line specification
1041 * The line number for that spec.
1044 gdb_get_line_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_SetIntObj (result_ptr
->obj_ptr
, sals
.sals
[0].line
);
1069 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1074 /* This implements the tcl command "gdb_get_file"
1076 * It returns the file containing a given line spec.
1079 * linespec - The linespec to look up
1081 * The file containing it.
1085 gdb_get_file_command (clientData
, interp
, objc
, objv
)
1086 ClientData clientData
;
1089 Tcl_Obj
*CONST objv
[];
1091 struct symtabs_and_lines sals
;
1092 char *args
, **canonical
;
1096 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1097 Tcl_GetStringFromObj (objv
[0], NULL
),
1098 " linespec\"", NULL
);
1102 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1103 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1104 if (sals
.nelts
== 1)
1106 Tcl_SetStringObj (result_ptr
->obj_ptr
, sals
.sals
[0].symtab
->filename
, -1);
1110 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1114 /* This implements the tcl command "gdb_get_function"
1116 * It finds the function containing the given line spec.
1119 * linespec - The line specification
1121 * The function that contains it, or "N/A" if it is not in a function.
1124 gdb_get_function_command (clientData
, interp
, objc
, objv
)
1125 ClientData clientData
;
1128 Tcl_Obj
*CONST objv
[];
1131 struct symtabs_and_lines sals
;
1132 char *args
, **canonical
;
1136 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1137 Tcl_GetStringFromObj (objv
[0], NULL
),
1138 " linespec\"", NULL
);
1142 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1143 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1144 if (sals
.nelts
== 1)
1146 resolve_sal_pc (&sals
.sals
[0]);
1147 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
1148 if (function
!= NULL
)
1150 Tcl_SetStringObj (result_ptr
->obj_ptr
, function
, -1);
1155 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1159 /* This implements the tcl command "gdb_find_file"
1161 * It searches the symbol tables to get the full pathname to a file.
1164 * filename: the file name to search for.
1166 * The full path to the file, or an empty string if the file is not
1171 gdb_find_file_command (clientData
, interp
, objc
, objv
)
1172 ClientData clientData
;
1175 Tcl_Obj
*CONST objv
[];
1177 char *filename
= NULL
;
1182 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
1186 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1188 filename
= st
->fullname
;
1190 if (filename
== NULL
)
1191 Tcl_SetStringObj (result_ptr
->obj_ptr
, "", 0);
1193 Tcl_SetStringObj (result_ptr
->obj_ptr
, filename
, -1);
1198 /* This implements the tcl command "gdb_listfiles"
1200 * This lists all the files in the current executible.
1202 * Note that this currently pulls in all sorts of filenames
1203 * that aren't really part of the executable. It would be
1204 * best if we could check each file to see if it actually
1205 * contains executable lines of code, but we can't do that
1209 * ?pathname? - If provided, only files which match pathname
1210 * (up to strlen(pathname)) are included. THIS DOES NOT
1211 * CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1212 * THE FULL PATHNAME!!!
1215 * A list of all matching files.
1218 gdb_listfiles (clientData
, interp
, objc
, objv
)
1219 ClientData clientData
;
1222 Tcl_Obj
*CONST objv
[];
1224 struct objfile
*objfile
;
1225 struct partial_symtab
*psymtab
;
1226 struct symtab
*symtab
;
1227 char *lastfile
, *pathname
=NULL
, **files
;
1229 int i
, numfiles
= 0, len
= 0;
1232 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1236 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1240 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1242 ALL_PSYMTABS (objfile
, psymtab
)
1244 if (numfiles
== files_size
)
1246 files_size
= files_size
* 2;
1247 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1249 if (psymtab
->filename
)
1251 if (!len
|| !strncmp(pathname
, psymtab
->filename
,len
)
1252 || !strcmp(psymtab
->filename
, basename(psymtab
->filename
)))
1254 files
[numfiles
++] = basename(psymtab
->filename
);
1259 ALL_SYMTABS (objfile
, symtab
)
1261 if (numfiles
== files_size
)
1263 files_size
= files_size
* 2;
1264 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1266 if (symtab
->filename
&& symtab
->linetable
&& symtab
->linetable
->nitems
)
1268 if (!len
|| !strncmp(pathname
, symtab
->filename
,len
)
1269 || !strcmp(symtab
->filename
, basename(symtab
->filename
)))
1271 files
[numfiles
++] = basename(symtab
->filename
);
1276 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1280 /* Discard the old result pointer, in case it has accumulated anything
1281 and set it to a new list object */
1283 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1285 for (i
= 0; i
< numfiles
; i
++)
1287 if (strcmp(files
[i
],lastfile
))
1288 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj(files
[i
], -1));
1289 lastfile
= files
[i
];
1297 comp_files (file1
, file2
)
1298 const void *file1
, *file2
;
1300 return strcmp(* (char **) file1
, * (char **) file2
);
1304 /* This implements the tcl command "gdb_search"
1308 * option - One of "functions", "variables" or "types"
1309 * regexp - The regular expression to look for.
1318 gdb_search (clientData
, interp
, objc
, objv
)
1319 ClientData clientData
;
1322 Tcl_Obj
*CONST objv
[];
1324 struct symbol_search
*ss
= NULL
;
1325 struct symbol_search
*p
;
1326 struct cleanup
*old_chain
= NULL
;
1327 Tcl_Obj
*CONST
*switch_objv
;
1328 int index
, switch_objc
, i
;
1329 namespace_enum space
= 0;
1331 int static_only
, nfiles
;
1332 Tcl_Obj
**file_list
;
1334 static char *search_options
[] = { "functions", "variables", "types", (char *) NULL
};
1335 static char *switches
[] = { "-files", "-static", (char *) NULL
};
1336 enum search_opts
{ SEARCH_FUNCTIONS
, SEARCH_VARIABLES
, SEARCH_TYPES
};
1337 enum switches_opts
{ SWITCH_FILES
, SWITCH_STATIC_ONLY
};
1341 Tcl_WrongNumArgs (interp
, 1, objv
, "option regexp ?arg ...?");
1342 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1346 if (Tcl_GetIndexFromObj (interp
, objv
[1], search_options
, "option", 0,
1349 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1353 /* Unfortunately, we cannot teach search_symbols to search on
1354 multiple regexps, so we have to do a two-tier search for
1355 any searches which choose to narrow the playing field. */
1356 switch ((enum search_opts
) index
)
1358 case SEARCH_FUNCTIONS
:
1359 space
= FUNCTIONS_NAMESPACE
; break;
1360 case SEARCH_VARIABLES
:
1361 space
= VARIABLES_NAMESPACE
; break;
1363 space
= TYPES_NAMESPACE
; break;
1366 regexp
= Tcl_GetStringFromObj (objv
[2], NULL
);
1367 /* Process any switches that refine the search */
1368 switch_objc
= objc
- 3;
1369 switch_objv
= objv
+ 3;
1373 files
= (char **) NULL
;
1374 while (switch_objc
> 0)
1376 if (Tcl_GetIndexFromObj (interp
, switch_objv
[0], switches
,
1377 "option", 0, &index
) != TCL_OK
)
1379 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1383 switch ((enum switches_opts
) index
)
1388 if (switch_objc
< 2)
1390 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList -static 1|0]");
1391 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1394 result
= Tcl_ListObjGetElements (interp
, switch_objv
[1], &nfiles
, &file_list
);
1395 if (result
!= TCL_OK
)
1398 files
= (char **) xmalloc (nfiles
* sizeof (char *));
1399 for (i
= 0; i
< nfiles
; i
++)
1400 files
[i
] = Tcl_GetStringFromObj (file_list
[i
], NULL
);
1405 case SWITCH_STATIC_ONLY
:
1406 if (switch_objc
< 2)
1408 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList] [-static 1|0]");
1409 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1412 if ( Tcl_GetBooleanFromObj (interp
, switch_objv
[1], &static_only
) !=
1414 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1424 search_symbols (regexp
, space
, nfiles
, files
, &ss
);
1426 old_chain
= make_cleanup ((make_cleanup_func
) free_search_symbols
, ss
);
1428 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1430 for (p
= ss
; p
!= NULL
; p
= p
->next
)
1434 if (static_only
&& p
->block
!= STATIC_BLOCK
)
1437 /* Strip off some C++ special symbols, like RTTI and global
1438 constructors/destructors. */
1439 if ((p
->symbol
!= NULL
&& !STREQN (SYMBOL_NAME (p
->symbol
), "__tf", 4)
1440 && !STREQN (SYMBOL_NAME (p
->symbol
), "_GLOBAL_", 8))
1441 || p
->msymbol
!= NULL
)
1443 elem
= Tcl_NewListObj (0, NULL
);
1445 if (p
->msymbol
== NULL
)
1446 Tcl_ListObjAppendElement (interp
, elem
,
1447 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->symbol
), -1));
1449 Tcl_ListObjAppendElement (interp
, elem
,
1450 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->msymbol
), -1));
1452 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, elem
);
1457 do_cleanups (old_chain
);
1462 /* This implements the tcl command gdb_listfuncs
1464 * It lists all the functions defined in a given file
1467 * file - the file to look in
1469 * A list of two element lists, the first element is
1470 * the symbol name, and the second is a boolean indicating
1471 * whether the symbol is demangled (1 for yes).
1475 gdb_listfuncs (clientData
, interp
, objc
, objv
)
1476 ClientData clientData
;
1479 Tcl_Obj
*CONST objv
[];
1481 struct symtab
*symtab
;
1482 struct blockvector
*bv
;
1486 Tcl_Obj
*funcVals
[2];
1490 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1493 symtab
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1496 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No such file", -1);
1500 if (mangled
== NULL
)
1502 mangled
= Tcl_NewBooleanObj(1);
1503 not_mangled
= Tcl_NewBooleanObj(0);
1504 Tcl_IncrRefCount(mangled
);
1505 Tcl_IncrRefCount(not_mangled
);
1508 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1510 bv
= BLOCKVECTOR (symtab
);
1511 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1513 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1514 /* Skip the sort if this block is always sorted. */
1515 if (!BLOCK_SHOULD_SORT (b
))
1516 sort_block_syms (b
);
1517 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1519 sym
= BLOCK_SYM (b
, j
);
1520 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1523 char *name
= SYMBOL_DEMANGLED_NAME (sym
);
1527 /* strip out "global constructors" and "global destructors" */
1528 /* because we aren't interested in them. */
1529 if (strncmp (name
, "global ", 7))
1531 /* If the function is overloaded, print out the functions
1532 declaration, not just its name. */
1534 funcVals
[0] = Tcl_NewStringObj(name
, -1);
1535 funcVals
[1] = mangled
;
1543 funcVals
[0] = Tcl_NewStringObj(SYMBOL_NAME(sym
), -1);
1544 funcVals
[1] = not_mangled
;
1546 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1547 Tcl_NewListObj (2, funcVals
));
1556 * This section contains all the commands that act on the registers:
1559 /* This is a sort of mapcar function for operations on registers */
1562 map_arg_registers (objc
, objv
, func
, argp
)
1564 Tcl_Obj
*CONST objv
[];
1565 void (*func
) PARAMS ((int regnum
, void *argp
));
1570 /* Note that the test for a valid register must include checking the
1571 REGISTER_NAME because NUM_REGS may be allocated for the union of
1572 the register sets within a family of related processors. In this
1573 case, some entries of REGISTER_NAME will change depending upon
1574 the particular processor being debugged. */
1576 if (objc
== 0) /* No args, just do all the regs */
1580 && REGISTER_NAME (regnum
) != NULL
1581 && *REGISTER_NAME (regnum
) != '\000';
1583 func (regnum
, argp
);
1588 /* Else, list of register #s, just do listed regs */
1589 for (; objc
> 0; objc
--, objv
++)
1591 if (Tcl_GetIntFromObj (NULL
, *objv
, ®num
) != TCL_OK
)
1593 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1598 && regnum
< NUM_REGS
1599 && REGISTER_NAME (regnum
) != NULL
1600 && *REGISTER_NAME (regnum
) != '\000')
1601 func (regnum
, argp
);
1604 Tcl_SetStringObj (result_ptr
->obj_ptr
, "bad register number", -1);
1612 /* This implements the TCL command `gdb_regnames', which returns a list of
1613 all of the register names. */
1616 gdb_regnames (clientData
, interp
, objc
, objv
)
1617 ClientData clientData
;
1620 Tcl_Obj
*CONST objv
[];
1625 return map_arg_registers (objc
, objv
, get_register_name
, NULL
);
1629 get_register_name (regnum
, argp
)
1631 void *argp
; /* Ignored */
1633 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1634 Tcl_NewStringObj (REGISTER_NAME (regnum
), -1));
1637 /* This implements the tcl command gdb_fetch_registers
1638 * Pass it a list of register names, and it will
1639 * return their values as a list.
1642 * format: The format string for printing the values
1643 * args: the registers to look for
1645 * A list of their values.
1649 gdb_fetch_registers (clientData
, interp
, objc
, objv
)
1650 ClientData clientData
;
1653 Tcl_Obj
*CONST objv
[];
1659 Tcl_SetStringObj (result_ptr
->obj_ptr
,
1660 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
1664 format
= *(Tcl_GetStringFromObj(objv
[0], NULL
));
1668 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Output the results as a list */
1669 result
= map_arg_registers (objc
, objv
, get_register
, (void *) format
);
1670 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
1676 get_register (regnum
, fp
)
1680 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1681 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
1682 int format
= (int)fp
;
1688 /* read_relative_register_raw_bytes returns a virtual frame pointer
1689 (FRAME_FP (selected_frame)) if regnum == FP_REGNUM instead
1690 of the real contents of the register. To get around this,
1691 use get_saved_register instead. */
1692 get_saved_register (raw_buffer
, &optim
, (CORE_ADDR
*) NULL
, selected_frame
,
1693 regnum
, (enum lval_type
*) NULL
);
1696 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1697 Tcl_NewStringObj ("Optimized out", -1));
1701 /* Convert raw data to virtual format if necessary. */
1703 if (REGISTER_CONVERTIBLE (regnum
))
1705 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
1706 raw_buffer
, virtual_buffer
);
1709 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1714 char *ptr
, buf
[1024];
1718 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1720 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1721 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1722 sprintf(ptr
, "%02x", (unsigned char)raw_buffer
[idx
]);
1725 fputs_filtered (buf
, gdb_stdout
);
1728 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0, 0,
1729 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1733 /* This implements the tcl command get_pc_reg
1734 * It returns the value of the PC register
1739 * The value of the pc register.
1743 get_pc_register (clientData
, interp
, objc
, objv
)
1744 ClientData clientData
;
1747 Tcl_Obj
*CONST objv
[];
1751 sprintf (buff
, "0x%llx",(long long) read_register (PC_REGNUM
));
1752 Tcl_SetStringObj(result_ptr
->obj_ptr
, buff
, -1);
1756 /* This implements the tcl command "gdb_changed_register_list"
1757 * It takes a list of registers, and returns a list of
1758 * the registers on that list that have changed since the last
1759 * time the proc was called.
1762 * A list of registers.
1764 * A list of changed registers.
1768 gdb_changed_register_list (clientData
, interp
, objc
, objv
)
1769 ClientData clientData
;
1772 Tcl_Obj
*CONST objv
[];
1777 return map_arg_registers (objc
, objv
, register_changed_p
, NULL
);
1781 register_changed_p (regnum
, argp
)
1783 void *argp
; /* Ignored */
1785 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1787 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1790 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1791 REGISTER_RAW_SIZE (regnum
)) == 0)
1794 /* Found a changed register. Save new value and return its number. */
1796 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1797 REGISTER_RAW_SIZE (regnum
));
1799 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(regnum
));
1803 * This section contains the commands that deal with tracepoints:
1806 /* return a list of all tracepoint numbers in interpreter */
1808 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
1809 ClientData clientData
;
1812 Tcl_Obj
*CONST objv
[];
1814 struct tracepoint
*tp
;
1816 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1818 ALL_TRACEPOINTS (tp
)
1819 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->number
));
1824 /* returns -1 if not found, tracepoint # if found */
1826 tracepoint_exists (char * args
)
1828 struct tracepoint
*tp
;
1830 struct symtabs_and_lines sals
;
1834 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1835 if (sals
.nelts
== 1)
1837 resolve_sal_pc (&sals
.sals
[0]);
1838 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
1839 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
1842 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
1843 strcat (file
, sals
.sals
[0].symtab
->filename
);
1845 ALL_TRACEPOINTS (tp
)
1847 if (tp
->address
== sals
.sals
[0].pc
)
1848 result
= tp
->number
;
1850 /* Why is this here? This messes up assembly traces */
1851 else if (tp
->source_file
!= NULL
1852 && strcmp (tp
->source_file
, file
) == 0
1853 && sals
.sals
[0].line
== tp
->line_number
)
1854 result
= tp
->number
;
1865 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
1866 ClientData clientData
;
1869 Tcl_Obj
*CONST objv
[];
1875 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1876 Tcl_GetStringFromObj (objv
[0], NULL
),
1877 " function:line|function|line|*addr\"", NULL
);
1881 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1883 Tcl_SetIntObj (result_ptr
->obj_ptr
, tracepoint_exists (args
));
1888 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
1889 ClientData clientData
;
1892 Tcl_Obj
*CONST objv
[];
1894 struct symtab_and_line sal
;
1896 struct tracepoint
*tp
;
1897 struct action_line
*al
;
1898 Tcl_Obj
*action_list
;
1899 char *filename
, *funcname
, *fname
;
1904 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1908 if (Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
) != TCL_OK
)
1910 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1914 ALL_TRACEPOINTS (tp
)
1915 if (tp
->number
== tpnum
)
1921 sprintf (buff
, "Tracepoint #%d does not exist", tpnum
);
1922 Tcl_SetStringObj (result_ptr
->obj_ptr
, buff
, -1);
1926 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1927 sal
= find_pc_line (tp
->address
, 0);
1928 filename
= symtab_to_filename (sal
.symtab
);
1929 if (filename
== NULL
)
1931 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1932 Tcl_NewStringObj (filename
, -1));
1934 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
1935 fname
= cplus_demangle (funcname
, 0);
1938 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj
1943 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj
1946 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (sal
.line
));
1947 sprintf (tmp
, "0x%lx", tp
->address
);
1948 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (tmp
, -1));
1949 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->enabled
));
1950 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->pass_count
));
1951 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->step_count
));
1952 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->thread
));
1953 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->hit_count
));
1955 /* Append a list of actions */
1956 action_list
= Tcl_NewObj ();
1957 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
1959 Tcl_ListObjAppendElement (interp
, action_list
,
1960 Tcl_NewStringObj (al
->action
, -1));
1962 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, action_list
);
1969 gdb_trace_status (clientData
, interp
, objc
, objv
)
1970 ClientData clientData
;
1973 Tcl_Obj
*CONST objv
[];
1977 if (trace_running_p
)
1980 Tcl_SetIntObj (result_ptr
->obj_ptr
, result
);
1987 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
1988 ClientData clientData
;
1991 Tcl_Obj
*CONST objv
[];
1995 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1996 Tcl_GetStringFromObj (objv
[0], NULL
),
1997 " linespec\"", NULL
);
2001 Tcl_SetIntObj (result_ptr
->obj_ptr
, get_traceframe_number ());
2006 /* This implements the tcl command gdb_actions
2007 * It sets actions for a given tracepoint.
2010 * number: the tracepoint in question
2011 * actions: the actions to add to this tracepoint
2017 gdb_actions_command (clientData
, interp
, objc
, objv
)
2018 ClientData clientData
;
2021 Tcl_Obj
*CONST objv
[];
2023 struct tracepoint
*tp
;
2025 int nactions
, i
, len
;
2026 char *number
, *args
, *action
;
2028 struct action_line
*next
= NULL
, *temp
;
2029 enum actionline_type linetype
;
2033 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # args: should be: \"",
2034 Tcl_GetStringFromObj (objv
[0], NULL
),
2035 " number actions\"", NULL
);
2039 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
2040 tp
= get_tracepoint_by_number (&args
);
2043 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "Tracepoint \"", number
, "\" does not exist", NULL
);
2047 /* Free any existing actions */
2048 if (tp
->actions
!= NULL
)
2053 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
2055 /* Add the actions to the tracepoint */
2056 for (i
= 0; i
< nactions
; i
++)
2058 temp
= xmalloc (sizeof (struct action_line
));
2060 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
2061 temp
->action
= savestring (action
, len
);
2063 linetype
= validate_actionline (&(temp
->action
), tp
);
2065 if (linetype
== BADLINE
)
2087 * This section has commands that handle source disassembly.
2090 /* This implements the tcl command gdb_disassemble
2093 * source_with_assm - must be "source" or "nosource"
2094 * low_address - the address from which to start disassembly
2095 * ?hi_address? - the address to which to disassemble, defaults
2096 * to the end of the function containing low_address.
2098 * The disassembled code is passed to fputs_unfiltered, so it
2099 * either goes to the console if result_ptr->obj_ptr is NULL or to
2104 gdb_disassemble (clientData
, interp
, objc
, objv
)
2105 ClientData clientData
;
2108 Tcl_Obj
*CONST objv
[];
2110 CORE_ADDR pc
, low
, high
;
2111 int mixed_source_and_assembly
;
2112 static disassemble_info di
;
2113 static int di_initialized
;
2116 if (objc
!= 3 && objc
!= 4)
2117 error ("wrong # args");
2119 if (! di_initialized
)
2121 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
2122 (fprintf_ftype
) fprintf_unfiltered
);
2123 di
.flavour
= bfd_target_unknown_flavour
;
2124 di
.memory_error_func
= dis_asm_memory_error
;
2125 di
.print_address_func
= dis_asm_print_address
;
2129 di
.mach
= TARGET_PRINT_INSN_INFO
->mach
;
2130 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
2131 di
.endian
= BFD_ENDIAN_BIG
;
2133 di
.endian
= BFD_ENDIAN_LITTLE
;
2135 arg_ptr
= Tcl_GetStringFromObj (objv
[1], NULL
);
2136 if (*arg_ptr
== 's' && strcmp (arg_ptr
, "source") == 0)
2137 mixed_source_and_assembly
= 1;
2138 else if (*arg_ptr
== 'n' && strcmp (arg_ptr
, "nosource") == 0)
2139 mixed_source_and_assembly
= 0;
2141 error ("First arg must be 'source' or 'nosource'");
2143 low
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[2], NULL
));
2147 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
2148 error ("No function contains specified address");
2151 high
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[3], NULL
));
2153 /* If disassemble_from_exec == -1, then we use the following heuristic to
2154 determine whether or not to do disassembly from target memory or from the
2157 If we're debugging a local process, read target memory, instead of the
2158 exec file. This makes disassembly of functions in shared libs work
2161 Else, we're debugging a remote process, and should disassemble from the
2162 exec file for speed. However, this is no good if the target modifies its
2163 code (for relocation, or whatever).
2166 if (disassemble_from_exec
== -1)
2168 if (strcmp (target_shortname
, "child") == 0
2169 || strcmp (target_shortname
, "procfs") == 0
2170 || strcmp (target_shortname
, "vxprocess") == 0)
2171 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
2173 disassemble_from_exec
= 1; /* It's remote, read the exec file */
2176 if (disassemble_from_exec
)
2177 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
2179 di
.read_memory_func
= dis_asm_read_memory
;
2181 /* If just doing straight assembly, all we need to do is disassemble
2182 everything between low and high. If doing mixed source/assembly, we've
2183 got a totally different path to follow. */
2185 if (mixed_source_and_assembly
)
2186 { /* Come here for mixed source/assembly */
2187 /* The idea here is to present a source-O-centric view of a function to
2188 the user. This means that things are presented in source order, with
2189 (possibly) out of order assembly immediately following. */
2190 struct symtab
*symtab
;
2191 struct linetable_entry
*le
;
2194 struct my_line_entry
*mle
;
2195 struct symtab_and_line sal
;
2200 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
2202 if (!symtab
|| !symtab
->linetable
)
2205 /* First, convert the linetable to a bunch of my_line_entry's. */
2207 le
= symtab
->linetable
->item
;
2208 nlines
= symtab
->linetable
->nitems
;
2213 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
2217 /* Copy linetable entries for this function into our data structure, creating
2218 end_pc's and setting out_of_order as appropriate. */
2220 /* First, skip all the preceding functions. */
2222 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
2224 /* Now, copy all entries before the end of this function. */
2227 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
2229 if (le
[i
].line
== le
[i
+ 1].line
2230 && le
[i
].pc
== le
[i
+ 1].pc
)
2231 continue; /* Ignore duplicates */
2233 mle
[newlines
].line
= le
[i
].line
;
2234 if (le
[i
].line
> le
[i
+ 1].line
)
2236 mle
[newlines
].start_pc
= le
[i
].pc
;
2237 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
2241 /* If we're on the last line, and it's part of the function, then we need to
2242 get the end pc in a special way. */
2247 mle
[newlines
].line
= le
[i
].line
;
2248 mle
[newlines
].start_pc
= le
[i
].pc
;
2249 sal
= find_pc_line (le
[i
].pc
, 0);
2250 mle
[newlines
].end_pc
= sal
.end
;
2254 /* Now, sort mle by line #s (and, then by addresses within lines). */
2257 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
2259 /* Now, for each line entry, emit the specified lines (unless they have been
2260 emitted before), followed by the assembly code for that line. */
2262 next_line
= 0; /* Force out first line */
2263 for (i
= 0; i
< newlines
; i
++)
2265 /* Print out everything from next_line to the current line. */
2267 if (mle
[i
].line
>= next_line
)
2270 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
2272 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
2274 next_line
= mle
[i
].line
+ 1;
2277 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
2280 fputs_unfiltered (" ", gdb_stdout
);
2281 print_address (pc
, gdb_stdout
);
2282 fputs_unfiltered (":\t ", gdb_stdout
);
2283 pc
+= (*tm_print_insn
) (pc
, &di
);
2284 fputs_unfiltered ("\n", gdb_stdout
);
2291 for (pc
= low
; pc
< high
; )
2294 fputs_unfiltered (" ", gdb_stdout
);
2295 print_address (pc
, gdb_stdout
);
2296 fputs_unfiltered (":\t ", gdb_stdout
);
2297 pc
+= (*tm_print_insn
) (pc
, &di
);
2298 fputs_unfiltered ("\n", gdb_stdout
);
2302 gdb_flush (gdb_stdout
);
2307 /* This is the memory_read_func for gdb_disassemble when we are
2308 disassembling from the exec file. */
2311 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
2315 disassemble_info
*info
;
2317 extern struct target_ops exec_ops
;
2321 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
2332 /* This will be passed to qsort to sort the results of the disassembly */
2335 compare_lines (mle1p
, mle2p
)
2339 struct my_line_entry
*mle1
, *mle2
;
2342 mle1
= (struct my_line_entry
*) mle1p
;
2343 mle2
= (struct my_line_entry
*) mle2p
;
2345 val
= mle1
->line
- mle2
->line
;
2350 return mle1
->start_pc
- mle2
->start_pc
;
2353 /* This implements the TCL command `gdb_loc',
2356 * ?symbol? The symbol or address to locate - defaults to pc
2358 * a list consisting of the following:
2359 * basename, function name, filename, line number, address, current pc
2363 gdb_loc (clientData
, interp
, objc
, objv
)
2364 ClientData clientData
;
2367 Tcl_Obj
*CONST objv
[];
2370 struct symtab_and_line sal
;
2372 char *funcname
, *fname
;
2377 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
2379 /* Note - this next line is not correct on all architectures. */
2380 /* For a graphical debugger we really want to highlight the */
2381 /* assembly line that called the next function on the stack. */
2382 /* Many architectures have the next instruction saved as the */
2383 /* pc on the stack, so what happens is the next instruction */
2384 /* is highlighted. FIXME */
2385 pc
= selected_frame
->pc
;
2386 sal
= find_pc_line (selected_frame
->pc
,
2387 selected_frame
->next
!= NULL
2388 && !selected_frame
->next
->signal_handler_caller
2389 && !frame_in_dummy (selected_frame
->next
));
2394 sal
= find_pc_line (stop_pc
, 0);
2399 struct symtabs_and_lines sals
;
2402 sals
= decode_line_spec (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
2408 if (sals
.nelts
!= 1)
2410 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Ambiguous line spec", -1);
2413 resolve_sal_pc (&sal
);
2418 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
2423 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2424 Tcl_NewStringObj (sal
.symtab
->filename
, -1));
2426 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewStringObj ("", 0));
2428 sym
= find_pc_function (pc
);
2431 fname
= SYMBOL_DEMANGLED_NAME (sym
);
2434 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2435 Tcl_NewStringObj (fname
, -1));
2438 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2439 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
2443 /* find_pc_function will fail if there are only minimal symbols */
2444 /* so do this instead... */
2445 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
2446 /* we try cplus demangling; a guess really */
2447 fname
= cplus_demangle (funcname
, 0);
2450 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2451 Tcl_NewStringObj (fname
, -1));
2455 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2456 Tcl_NewStringObj (funcname
, -1));
2459 filename
= symtab_to_filename (sal
.symtab
);
2460 if (filename
== NULL
)
2464 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2465 Tcl_NewStringObj (filename
, -1));
2467 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(sal
.line
));
2468 /* PC in current frame */
2469 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(pc
));
2471 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(stop_pc
));
2473 /* shared library */
2475 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2476 Tcl_NewStringObj (PC_SOLIB(pc
), -1));
2478 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2479 Tcl_NewStringObj ("", -1));
2484 /* This implements the Tcl command 'gdb_get_mem', which
2485 * dumps a block of memory
2487 * gdb_get_mem addr form size num aschar
2489 * addr: address of data to dump
2490 * form: a char indicating format
2491 * size: size of each element; 1,2,4, or 8 bytes
2492 * num: the number of bytes to read
2493 * acshar: an optional ascii character to use in ASCII dump
2496 * a list of elements followed by an optional ASCII dump
2500 gdb_get_mem (clientData
, interp
, objc
, objv
)
2501 ClientData clientData
;
2504 Tcl_Obj
*CONST objv
[];
2506 int size
, asize
, i
, j
, bc
;
2508 int nbytes
, rnum
, bpr
;
2510 char format
, c
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
2511 struct type
*val_type
;
2513 if (objc
< 6 || objc
> 7)
2515 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2516 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2520 if (Tcl_GetIntFromObj (interp
, objv
[3], &size
) != TCL_OK
)
2522 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2527 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid size, must be > 0", -1);
2531 if (Tcl_GetIntFromObj (interp
, objv
[4], &nbytes
) != TCL_OK
)
2533 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2538 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid number of bytes, must be > 0",
2543 if (Tcl_GetIntFromObj (interp
, objv
[5], &bpr
) != TCL_OK
)
2545 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2550 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid bytes per row, must be > 0", -1);
2554 if (Tcl_GetLongFromObj (interp
, objv
[1], &tmp
) != TCL_OK
)
2557 addr
= (CORE_ADDR
) tmp
;
2559 format
= *(Tcl_GetStringFromObj (objv
[2], NULL
));
2560 mbuf
= (char *)malloc (nbytes
+32);
2563 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Out of memory.", -1);
2567 memset (mbuf
, 0, nbytes
+32);
2570 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
2573 aschar
= *(Tcl_GetStringFromObj(objv
[6], NULL
));
2579 val_type
= builtin_type_char
;
2583 val_type
= builtin_type_short
;
2587 val_type
= builtin_type_int
;
2591 val_type
= builtin_type_long_long
;
2595 val_type
= builtin_type_char
;
2599 bc
= 0; /* count of bytes in a row */
2600 buff
[0] = '"'; /* buffer for ascii dump */
2601 bptr
= &buff
[1]; /* pointer for ascii dump */
2603 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Build up the result as a list... */
2605 for (i
=0; i
< nbytes
; i
+= size
)
2609 fputs_unfiltered ("N/A ", gdb_stdout
);
2611 for ( j
= 0; j
< size
; j
++)
2616 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
2620 for ( j
= 0; j
< size
; j
++)
2623 if (c
< 32 || c
> 126)
2635 if (aschar
&& (bc
>= bpr
))
2637 /* end of row. print it and reset variables */
2642 fputs_unfiltered (buff
, gdb_stdout
);
2647 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
2655 /* This implements the tcl command "gdb_loadfile"
2656 * It loads a c source file into a text widget.
2659 * widget: the name of the text widget to fill
2660 * filename: the name of the file to load
2661 * linenumbers: A boolean indicating whether or not to display line numbers.
2666 /* In this routine, we will build up a "line table", i.e. a
2667 * table of bits showing which lines in the source file are executible.
2668 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2670 * Its size limits the maximum number of lines
2671 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2672 * the file is loaded, so it is OK to make this very large.
2673 * Additional memory will be allocated if needed. */
2674 #define LTABLE_SIZE 20000
2676 gdb_loadfile (clientData
, interp
, objc
, objv
)
2677 ClientData clientData
;
2680 Tcl_Obj
*CONST objv
[];
2682 char *file
, *widget
;
2683 int linenumbers
, ln
, lnum
, ltable_size
;
2686 struct symtab
*symtab
;
2687 struct linetable_entry
*le
;
2690 Tcl_DString text_cmd_1
, text_cmd_2
, *cur_cmd
;
2691 char line
[10000], line_num_buf
[16];
2692 int prefix_len_1
, prefix_len_2
, cur_prefix_len
, widget_len
;
2697 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
2701 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
2702 if ( Tk_NameToWindow (interp
, widget
, Tk_MainWindow (interp
)) == NULL
)
2707 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
2708 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
2710 symtab
= full_lookup_symtab (file
);
2713 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "File not found in symtab", -1);
2718 file
= symtab_to_filename ( symtab
);
2719 if ((fp
= fopen ( file
, "r" )) == NULL
)
2721 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Can't open file for reading", -1);
2725 if (stat (file
, &st
) < 0)
2727 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
2732 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
2733 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
2735 mtime
= bfd_get_mtime(exec_bfd
);
2737 if (mtime
&& mtime
< st
.st_mtime
)
2738 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2741 /* Source linenumbers don't appear to be in order, and a sort is */
2742 /* too slow so the fastest solution is just to allocate a huge */
2743 /* array and set the array entry for each linenumber */
2745 ltable_size
= LTABLE_SIZE
;
2746 ltable
= (char *)malloc (LTABLE_SIZE
);
2749 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2754 memset (ltable
, 0, LTABLE_SIZE
);
2756 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
2758 le
= symtab
->linetable
->item
;
2759 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
2761 lnum
= le
->line
>> 3;
2762 if (lnum
>= ltable_size
)
2765 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
2766 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
2768 if (new_ltable
== NULL
)
2770 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2775 ltable
= new_ltable
;
2777 ltable
[lnum
] |= 1 << (le
->line
% 8);
2781 Tcl_DStringInit(&text_cmd_1
);
2782 Tcl_DStringInit(&text_cmd_2
);
2786 widget_len
= strlen (widget
);
2789 Tcl_DStringAppend (&text_cmd_1
, widget
, widget_len
);
2790 Tcl_DStringAppend (&text_cmd_2
, widget
, widget_len
);
2794 Tcl_DStringAppend (&text_cmd_1
, " insert end {-\t", -1);
2795 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2797 Tcl_DStringAppend (&text_cmd_2
, " insert end { \t", -1);
2798 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2800 while (fgets (line
+ 1, 9980, fp
))
2802 sprintf (line_num_buf
, "%d", ln
);
2803 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2805 cur_cmd
= &text_cmd_1
;
2806 cur_prefix_len
= prefix_len_1
;
2807 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2808 Tcl_DStringAppend (cur_cmd
, "} break_rgn_tag", 15);
2812 cur_cmd
= &text_cmd_2
;
2813 cur_prefix_len
= prefix_len_2
;
2814 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2815 Tcl_DStringAppend (cur_cmd
, "} \"\"", 4);
2818 Tcl_DStringAppendElement (cur_cmd
, line
);
2819 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2821 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2822 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2828 Tcl_DStringAppend (&text_cmd_1
, " insert end {- } break_rgn_tag", -1);
2829 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2830 Tcl_DStringAppend (&text_cmd_2
, " insert end { } \"\"", -1);
2831 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2833 while (fgets (line
+ 1, 980, fp
))
2835 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2837 cur_cmd
= &text_cmd_1
;
2838 cur_prefix_len
= prefix_len_1
;
2842 cur_cmd
= &text_cmd_2
;
2843 cur_prefix_len
= prefix_len_2
;
2846 Tcl_DStringAppendElement (cur_cmd
, line
);
2847 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2849 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2850 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2856 Tcl_DStringFree (&text_cmd_1
);
2857 Tcl_DStringFree (&text_cmd_2
);
2864 * This section contains commands for manipulation of breakpoints.
2868 /* set a breakpoint by source file and line number */
2869 /* flags are as follows: */
2870 /* least significant 2 bits are disposition, rest is */
2871 /* type (normally 0).
2874 bp_breakpoint, Normal breakpoint
2875 bp_hardware_breakpoint, Hardware assisted breakpoint
2878 Disposition of breakpoint. Ie: what to do after hitting it.
2881 del_at_next_stop, Delete at next stop, whether hit or not
2883 donttouch Leave it alone
2887 /* This implements the tcl command "gdb_set_bp"
2888 * It sets breakpoints, and runs the Tcl command
2889 * gdbtk_tcl_breakpoint create
2890 * to register the new breakpoint with the GUI.
2893 * filename: the file in which to set the breakpoint
2894 * line: the line number for the breakpoint
2895 * type: the type of the breakpoint
2896 * thread: optional thread number
2898 * The return value of the call to gdbtk_tcl_breakpoint.
2902 gdb_set_bp (clientData
, interp
, objc
, objv
)
2903 ClientData clientData
;
2906 Tcl_Obj
*CONST objv
[];
2908 struct symtab_and_line sal
;
2909 int line
, ret
, thread
= -1;
2910 struct breakpoint
*b
;
2911 char buf
[64], *typestr
;
2915 if (objc
!= 4 && objc
!= 5)
2917 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2918 "wrong number of args, should be \"filename line type [thread]\"", -1);
2922 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
2923 if (sal
.symtab
== NULL
)
2926 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
2928 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2932 typestr
= Tcl_GetStringFromObj( objv
[3], NULL
);
2933 if (typestr
== NULL
)
2935 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2938 if (strncmp( typestr
, "temp", 4 ) == 0)
2940 else if (strncmp( typestr
, "normal", 6 ) == 0)
2944 Tcl_SetStringObj (result_ptr
->obj_ptr
, "type must be \"temp\" or \"normal\"", -1);
2950 if (Tcl_GetIntFromObj( interp
, objv
[4], &thread
) == TCL_ERROR
)
2952 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2958 if (!find_line_pc (sal
.symtab
, sal
.line
, &sal
.pc
))
2961 sal
.section
= find_pc_overlay (sal
.pc
);
2962 b
= set_raw_breakpoint (sal
);
2963 set_breakpoint_count (breakpoint_count
+ 1);
2964 b
->number
= breakpoint_count
;
2965 b
->type
= bp_breakpoint
;
2966 b
->disposition
= disp
;
2969 /* FIXME: this won't work for duplicate basenames! */
2970 sprintf (buf
, "%s:%d", basename (Tcl_GetStringFromObj ( objv
[1], NULL
)), line
);
2971 b
->addr_string
= strsave (buf
);
2973 /* now send notification command back to GUI */
2975 Tcl_DStringInit (&cmd
);
2977 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2978 sprintf (buf
, "%d", b
->number
);
2979 Tcl_DStringAppendElement(&cmd
, buf
);
2980 sprintf (buf
, "0x%lx", (long)sal
.pc
);
2981 Tcl_DStringAppendElement (&cmd
, buf
);
2982 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[2], NULL
));
2983 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[1], NULL
));
2984 Tcl_DStringAppendElement (&cmd
, bpdisp
[b
->disposition
]);
2985 sprintf (buf
, "%d", b
->enable
);
2986 Tcl_DStringAppendElement (&cmd
, buf
);
2987 sprintf (buf
, "%d", b
->thread
);
2988 Tcl_DStringAppendElement (&cmd
, buf
);
2991 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2992 Tcl_DStringFree (&cmd
);
2996 /* This implements the tcl command "gdb_set_bp_addr"
2997 * It sets breakpoints, and runs the Tcl command
2998 * gdbtk_tcl_breakpoint create
2999 * to register the new breakpoint with the GUI.
3002 * addr: the address at which to set the breakpoint
3003 * type: the type of the breakpoint
3004 * thread: optional thread number
3006 * The return value of the call to gdbtk_tcl_breakpoint.
3010 gdb_set_bp_addr (clientData
, interp
, objc
, objv
)
3011 ClientData clientData
;
3014 Tcl_Obj
*CONST objv
[];
3017 struct symtab_and_line sal
;
3018 int line
, ret
, thread
= -1;
3020 struct breakpoint
*b
;
3021 char *filename
, *typestr
, buf
[64];
3025 if (objc
!= 4 && objc
!= 3)
3027 Tcl_SetStringObj (result_ptr
->obj_ptr
,
3028 "wrong number of args, should be \"address type [thread]\"", -1);
3032 if (Tcl_GetLongFromObj( interp
, objv
[1], &addr
) == TCL_ERROR
)
3034 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3038 typestr
= Tcl_GetStringFromObj( objv
[2], NULL
);
3039 if (typestr
== NULL
)
3041 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3044 if (strncmp( typestr
, "temp", 4 ) == 0)
3046 else if (strncmp( typestr
, "normal", 6 ) == 0)
3050 Tcl_SetStringObj (result_ptr
->obj_ptr
, "type must be \"temp\" or \"normal\"", -1);
3056 if (Tcl_GetIntFromObj( interp
, objv
[3], &thread
) == TCL_ERROR
)
3058 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3063 sal
= find_pc_line (addr
, 0);
3065 b
= set_raw_breakpoint (sal
);
3066 set_breakpoint_count (breakpoint_count
+ 1);
3067 b
->number
= breakpoint_count
;
3068 b
->type
= bp_breakpoint
;
3069 b
->disposition
= disp
;
3072 sprintf (buf
, "*(0x%lx)",addr
);
3073 b
->addr_string
= strsave (buf
);
3075 /* now send notification command back to GUI */
3077 Tcl_DStringInit (&cmd
);
3079 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
3080 sprintf (buf
, "%d", b
->number
);
3081 Tcl_DStringAppendElement(&cmd
, buf
);
3082 sprintf (buf
, "0x%lx", addr
);
3083 Tcl_DStringAppendElement (&cmd
, buf
);
3084 sprintf (buf
, "%d", b
->line_number
);
3085 Tcl_DStringAppendElement (&cmd
, buf
);
3087 filename
= symtab_to_filename (sal
.symtab
);
3088 if (filename
== NULL
)
3090 Tcl_DStringAppendElement (&cmd
, filename
);
3091 Tcl_DStringAppendElement (&cmd
, bpdisp
[b
->disposition
]);
3092 sprintf (buf
, "%d", b
->enable
);
3093 Tcl_DStringAppendElement (&cmd
, buf
);
3094 sprintf (buf
, "%d", b
->thread
);
3095 Tcl_DStringAppendElement (&cmd
, buf
);
3097 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
3098 Tcl_DStringFree (&cmd
);
3102 /* This implements the tcl command "gdb_find_bp_at_line"
3105 * filename: the file in which to find the breakpoint
3106 * line: the line number for the breakpoint
3108 * It returns a list of breakpoint numbers
3112 gdb_find_bp_at_line(clientData
, interp
, objc
, objv
)
3113 ClientData clientData
;
3116 Tcl_Obj
*CONST objv
[];
3121 struct breakpoint
*b
;
3122 extern struct breakpoint
*breakpoint_chain
;
3126 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line");
3130 s
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
3134 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
3136 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3140 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3141 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3142 if (b
->line_number
== line
&& !strcmp(b
->source_file
, s
->filename
))
3143 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3144 Tcl_NewIntObj (b
->number
));
3150 /* This implements the tcl command "gdb_find_bp_at_addr"
3155 * It returns a list of breakpoint numbers
3159 gdb_find_bp_at_addr(clientData
, interp
, objc
, objv
)
3160 ClientData clientData
;
3163 Tcl_Obj
*CONST objv
[];
3167 struct breakpoint
*b
;
3168 extern struct breakpoint
*breakpoint_chain
;
3172 Tcl_WrongNumArgs(interp
, 1, objv
, "address");
3176 if (Tcl_GetLongFromObj( interp
, objv
[1], &addr
) == TCL_ERROR
)
3178 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3182 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3183 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3184 if (b
->address
== (CORE_ADDR
)addr
)
3185 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3186 Tcl_NewIntObj (b
->number
));
3191 /* This implements the tcl command gdb_get_breakpoint_info
3197 * A list with {file, function, line_number, address, type, enabled?,
3198 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
3202 gdb_get_breakpoint_info (clientData
, interp
, objc
, objv
)
3203 ClientData clientData
;
3206 Tcl_Obj
*CONST objv
[];
3208 struct symtab_and_line sal
;
3209 struct command_line
*cmd
;
3211 struct breakpoint
*b
;
3212 extern struct breakpoint
*breakpoint_chain
;
3213 char *funcname
, *fname
, *filename
;
3218 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong number of args, should be \"breakpoint\"", -1);
3222 if ( Tcl_GetIntFromObj(NULL
, objv
[1], &bpnum
) != TCL_OK
)
3224 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
3228 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3229 if (b
->number
== bpnum
)
3232 if (!b
|| b
->type
!= bp_breakpoint
)
3235 sprintf(err_buf
, "Breakpoint #%d does not exist.", bpnum
);
3236 Tcl_SetStringObj (result_ptr
->obj_ptr
, err_buf
, -1);
3240 sal
= find_pc_line (b
->address
, 0);
3242 filename
= symtab_to_filename (sal
.symtab
);
3243 if (filename
== NULL
)
3246 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
3247 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3248 Tcl_NewStringObj (filename
, -1));
3250 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
3251 fname
= cplus_demangle (funcname
, 0);
3254 new_obj
= Tcl_NewStringObj (fname
, -1);
3258 new_obj
= Tcl_NewStringObj (funcname
, -1);
3260 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
3262 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->line_number
));
3263 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(b
->address
));
3264 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3265 Tcl_NewStringObj (bptypes
[b
->type
], -1));
3266 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewBooleanObj(b
->enable
== enabled
));
3267 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3268 Tcl_NewStringObj (bpdisp
[b
->disposition
], -1));
3269 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->ignore_count
));
3271 new_obj
= Tcl_NewObj();
3272 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
3273 Tcl_ListObjAppendElement (NULL
, new_obj
,
3274 Tcl_NewStringObj (cmd
->line
, -1));
3275 Tcl_ListObjAppendElement(NULL
, result_ptr
->obj_ptr
, new_obj
);
3277 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
3278 Tcl_NewStringObj (b
->cond_string
, -1));
3280 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->thread
));
3281 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->hit_count
));
3287 /* This implements the tcl command gdb_get_breakpoint_list
3288 * It builds up a list of the current breakpoints.
3293 * A list of breakpoint numbers.
3297 gdb_get_breakpoint_list (clientData
, interp
, objc
, objv
)
3298 ClientData clientData
;
3301 Tcl_Obj
*CONST objv
[];
3303 struct breakpoint
*b
;
3304 extern struct breakpoint
*breakpoint_chain
;
3308 error ("wrong number of args, none are allowed");
3310 for (b
= breakpoint_chain
; b
; b
= b
->next
)
3311 if (b
->type
== bp_breakpoint
)
3313 new_obj
= Tcl_NewIntObj (b
->number
);
3314 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
3320 /* The functions in this section deal with stacks and backtraces. */
3322 /* This implements the tcl command gdb_stack.
3323 * It builds up a list of stack frames.
3326 * start - starting stack frame
3327 * count - number of frames to inspect
3329 * A list of function names
3333 gdb_stack (clientData
, interp
, objc
, objv
) ClientData clientData
;
3336 Tcl_Obj
*CONST objv
[];
3342 Tcl_WrongNumArgs (interp
, 1, objv
, "start count");
3343 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3347 if (Tcl_GetIntFromObj (NULL
, objv
[1], &start
))
3349 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3352 if (Tcl_GetIntFromObj (NULL
, objv
[2], &count
))
3354 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3358 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
3360 if (target_has_stack
)
3362 struct frame_info
*top
;
3363 struct frame_info
*fi
;
3365 /* Find the outermost frame */
3366 fi
= get_current_frame ();
3370 fi
= get_prev_frame (fi
);
3373 /* top now points to the top (outermost frame) of the
3374 stack, so point it to the requested start */
3376 top
= find_relative_frame (top
, &start
);
3378 /* If start != 0, then we have asked to start outputting
3379 frames beyond the innermost stack frame */
3383 while (fi
&& count
--)
3385 get_frame_name (interp
, result_ptr
->obj_ptr
, fi
);
3386 fi
= get_next_frame (fi
);
3394 /* A helper function for get_stack which adds information about
3395 * the stack frame FI to the caller's LIST.
3397 * This is stolen from print_frame_info in stack.c.
3400 get_frame_name (interp
, list
, fi
)
3403 struct frame_info
*fi
;
3405 struct symtab_and_line sal
;
3406 struct symbol
*func
= NULL
;
3407 register char *funname
= 0;
3408 enum language funlang
= language_unknown
;
3411 if (frame_in_dummy (fi
))
3413 objv
[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
3414 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3417 if (fi
->signal_handler_caller
)
3419 objv
[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
3420 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3425 find_pc_line (fi
->pc
,
3427 && !fi
->next
->signal_handler_caller
3428 && !frame_in_dummy (fi
->next
));
3430 func
= find_pc_function (fi
->pc
);
3433 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3435 && (SYMBOL_VALUE_ADDRESS (msymbol
)
3436 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
3439 funname
= GDBTK_SYMBOL_SOURCE_NAME (msymbol
);
3440 funlang
= SYMBOL_LANGUAGE (msymbol
);
3444 funname
= GDBTK_SYMBOL_SOURCE_NAME (func
);
3445 funlang
= SYMBOL_LANGUAGE (func
);
3450 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3451 if (msymbol
!= NULL
)
3453 funname
= GDBTK_SYMBOL_SOURCE_NAME (msymbol
);
3454 funlang
= SYMBOL_LANGUAGE (msymbol
);
3462 objv
[0] = Tcl_NewStringObj (funname
, -1);
3463 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3468 /* we have no convenient way to deal with this yet... */
3469 if (fi
->pc
!= sal
.pc
|| !sal
.symtab
)
3471 print_address_numeric (fi
->pc
, 1, gdb_stdout
);
3472 printf_filtered (" in ");
3474 printf_symbol_filtered (gdb_stdout
, funname
? funname
: "??", funlang
,
3477 objv
[0] = Tcl_NewStringObj (funname
!= NULL
? funname
: "??", -1);
3478 #ifdef PC_LOAD_SEGMENT
3479 /* If we couldn't print out function name but if can figure out what
3480 load segment this pc value is from, at least print out some info
3481 about its load segment. */
3484 Tcl_AppendStringsToObj (objv
[0], " from ", PC_LOAD_SEGMENT (fi
->pc
),
3491 char *lib
= PC_SOLIB (fi
->pc
);
3494 Tcl_AppendStringsToObj (objv
[0], " from ", lib
, (char *) NULL
);
3498 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3504 * This section contains a bunch of miscellaneous utility commands
3507 /* This implements the tcl command gdb_path_conv
3509 * On Windows, it canonicalizes the pathname,
3510 * On Unix, it is a no op.
3515 * The canonicalized path.
3519 gdb_path_conv (clientData
, interp
, objc
, objv
)
3520 ClientData clientData
;
3523 Tcl_Obj
*CONST objv
[];
3526 error ("wrong # args");
3530 char pathname
[256], *ptr
;
3532 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj (objv
[1], NULL
), pathname
);
3533 for (ptr
= pathname
; *ptr
; ptr
++)
3538 Tcl_SetStringObj (result_ptr
->obj_ptr
, pathname
, -1);
3541 Tcl_SetStringObj (result_ptr
->obj_ptr
, Tcl_GetStringFromObj (objv
[1], NULL
), -1);
3548 * This section has utility routines that are not Tcl commands.
3552 perror_with_name_wrapper (args
)
3555 perror_with_name (args
);
3559 /* The lookup_symtab() in symtab.c doesn't work correctly */
3560 /* It will not work will full pathnames and if multiple */
3561 /* source files have the same basename, it will return */
3562 /* the first one instead of the correct one. This version */
3563 /* also always makes sure symtab->fullname is set. */
3565 static struct symtab
*
3566 full_lookup_symtab(file
)
3570 struct objfile
*objfile
;
3571 char *bfile
, *fullname
;
3572 struct partial_symtab
*pt
;
3577 /* first try a direct lookup */
3578 st
= lookup_symtab (file
);
3582 symtab_to_filename(st
);
3586 /* if the direct approach failed, try */
3587 /* looking up the basename and checking */
3588 /* all matches with the fullname */
3589 bfile
= basename (file
);
3590 ALL_SYMTABS (objfile
, st
)
3592 if (!strcmp (bfile
, basename(st
->filename
)))
3595 fullname
= symtab_to_filename (st
);
3597 fullname
= st
->fullname
;
3599 if (!strcmp (file
, fullname
))
3604 /* still no luck? look at psymtabs */
3605 ALL_PSYMTABS (objfile
, pt
)
3607 if (!strcmp (bfile
, basename(pt
->filename
)))
3609 st
= PSYMTAB_TO_SYMTAB (pt
);
3612 fullname
= symtab_to_filename (st
);
3613 if (!strcmp (file
, fullname
))
3621 /* Local variables: */
3622 /* change-log-default-name: "ChangeLog-gdbtk" */