1 /* Tcl/Tk command definitions for gdbtk.
2 Copyright 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
4 Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
6 This file is part of GDB.
8 This program is free software; you can redistribute it and/or modify
9 it under the terms of the GNU General Public License as published by
10 the Free Software Foundation; either version 2 of the License, or
11 (at your option) any later version.
13 This program is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 GNU General Public License for more details.
18 You should have received a copy of the GNU General Public License
19 along with this program; if not, write to the Free Software
20 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
31 #include "tracepoint.h"
48 /* start-sanitize-ide */
52 /* end-sanitize-ide */
55 #ifdef ANSI_PROTOTYPES
65 #include <sys/ioctl.h>
66 #include "gdb_string.h"
74 /* This structure filled in call_wrapper and passed to
75 the wrapped call function.
76 It stores the command pointer and arguments
77 run in the wrapper function. */
79 struct wrapped_call_args
88 /* These two objects hold boolean true and false,
89 and are shared by all the list objects that gdb_listfuncs
92 static Tcl_Obj
*mangled
, *not_mangled
;
94 /* These two control how the GUI behaves when gdb is either tracing or loading.
95 They are used in this file & gdbtk_hooks.c */
98 int load_in_progress
= 0;
101 * This is used in the register fetching routines
104 #ifndef REGISTER_CONVERTIBLE
105 #define REGISTER_CONVERTIBLE(x) (0 != 0)
108 #ifndef REGISTER_CONVERT_TO_VIRTUAL
109 #define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
112 #ifndef INVALID_FLOAT
113 #define INVALID_FLOAT(x, y) (0 != 0)
118 /* This Structure is used in gdb_disassemble.
119 We need a different sort of line table from the normal one cuz we can't
120 depend upon implicit line-end pc's for lines to do the
121 reordering in this function. */
123 struct my_line_entry
{
129 /* This contains the previous values of the registers, since the last call to
130 gdb_changed_register_list. */
132 static char old_regs
[REGISTER_BYTES
];
135 * These are routines we need from breakpoint.c.
136 * at some point make these static in breakpoint.c and move GUI code there
139 extern struct breakpoint
*set_raw_breakpoint (struct symtab_and_line sal
);
140 extern void set_breakpoint_count (int);
141 extern int breakpoint_count
;
145 * Declarations for routines exported from this file
148 int Gdbtk_Init (Tcl_Interp
*interp
);
151 * Declarations for routines used only in this file.
154 static int compare_lines
PARAMS ((const PTR
, const PTR
));
155 static int comp_files
PARAMS ((const void *, const void *));
156 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
157 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
158 Tcl_Obj
*CONST objv
[]));
159 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
160 static int gdb_clear_file
PARAMS ((ClientData
, Tcl_Interp
*interp
, int, Tcl_Obj
*CONST
[]));
161 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
162 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
163 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int,
165 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
166 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
167 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
168 Tcl_Obj
*CONST objv
[]));
169 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
170 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
171 static int gdb_get_args_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
172 Tcl_Obj
*CONST objv
[]));
173 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
174 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
175 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
176 Tcl_Obj
*CONST objv
[]));
177 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
178 Tcl_Obj
*CONST objv
[]));
179 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
180 Tcl_Obj
*CONST objv
[]));
181 static int gdb_get_locals_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
182 Tcl_Obj
*CONST objv
[]));
183 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
184 static int gdb_get_trace_frame_num
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
185 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int,
186 Tcl_Obj
*CONST objv
[]));
187 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
188 Tcl_Obj
*CONST objv
[]));
189 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
190 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
191 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
192 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
193 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
194 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
195 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
196 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
197 Tcl_Obj
*CONST objv
[]));
198 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
199 static int gdb_search
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
201 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
202 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
203 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*,
206 static int gdb_trace_status
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
207 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*,
209 Tcl_Obj
*CONST objv
[]));
210 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int,
211 Tcl_Obj
*CONST objv
[]));
212 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
213 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
214 static int gdb_stack
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
216 char * get_prompt
PARAMS ((void));
217 static void get_register
PARAMS ((int, void *));
218 static void get_register_name
PARAMS ((int, void *));
219 static int map_arg_registers
PARAMS ((int, Tcl_Obj
*CONST
[], void (*) (int, void *), void *));
220 static int perror_with_name_wrapper
PARAMS ((char *args
));
221 static void register_changed_p
PARAMS ((int, void *));
222 void TclDebug
PARAMS ((const char *fmt
, ...));
223 static int wrapped_call (char *opaque_args
);
224 static void get_frame_name
PARAMS ((Tcl_Interp
*interp
, Tcl_Obj
*list
, struct frame_info
*fi
));
227 * This loads all the Tcl commands into the Tcl interpreter.
230 * interp - The interpreter into which to load the commands.
233 * A standard Tcl result.
240 Tcl_CreateObjCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
241 Tcl_CreateObjCommand (interp
, "gdb_immediate", call_wrapper
,
242 gdb_immediate_command
, NULL
);
243 Tcl_CreateObjCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
244 Tcl_CreateObjCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
245 Tcl_CreateObjCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
, NULL
);
246 Tcl_CreateObjCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
248 Tcl_CreateObjCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
250 Tcl_CreateObjCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
251 Tcl_CreateObjCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
252 Tcl_CreateObjCommand (interp
, "gdb_fetch_registers", call_wrapper
,
253 gdb_fetch_registers
, NULL
);
254 Tcl_CreateObjCommand (interp
, "gdb_changed_register_list", call_wrapper
,
255 gdb_changed_register_list
, NULL
);
256 Tcl_CreateObjCommand (interp
, "gdb_disassemble", call_wrapper
,
257 gdb_disassemble
, NULL
);
258 Tcl_CreateObjCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
259 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
260 gdb_get_breakpoint_list
, NULL
);
261 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
262 gdb_get_breakpoint_info
, NULL
);
263 Tcl_CreateObjCommand (interp
, "gdb_clear_file", call_wrapper
,
264 gdb_clear_file
, NULL
);
265 Tcl_CreateObjCommand (interp
, "gdb_confirm_quit", call_wrapper
,
266 gdb_confirm_quit
, NULL
);
267 Tcl_CreateObjCommand (interp
, "gdb_force_quit", call_wrapper
,
268 gdb_force_quit
, NULL
);
269 Tcl_CreateObjCommand (interp
, "gdb_target_has_execution",
271 gdb_target_has_execution_command
, NULL
);
272 Tcl_CreateObjCommand (interp
, "gdb_is_tracing",
273 call_wrapper
, gdb_trace_status
,
275 Tcl_CreateObjCommand (interp
, "gdb_load_info", call_wrapper
, gdb_load_info
, NULL
);
276 Tcl_CreateObjCommand (interp
, "gdb_get_locals", call_wrapper
, gdb_get_locals_command
,
278 Tcl_CreateObjCommand (interp
, "gdb_get_args", call_wrapper
, gdb_get_args_command
,
280 Tcl_CreateObjCommand (interp
, "gdb_get_function", call_wrapper
, gdb_get_function_command
,
282 Tcl_CreateObjCommand (interp
, "gdb_get_line", call_wrapper
, gdb_get_line_command
,
284 Tcl_CreateObjCommand (interp
, "gdb_get_file", call_wrapper
, gdb_get_file_command
,
286 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
287 call_wrapper
, gdb_tracepoint_exists_command
, NULL
);
288 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
289 call_wrapper
, gdb_get_tracepoint_info
, NULL
);
290 Tcl_CreateObjCommand (interp
, "gdb_actions",
291 call_wrapper
, gdb_actions_command
, NULL
);
292 Tcl_CreateObjCommand (interp
, "gdb_prompt",
293 call_wrapper
, gdb_prompt_command
, NULL
);
294 Tcl_CreateObjCommand (interp
, "gdb_find_file",
295 call_wrapper
, gdb_find_file_command
, NULL
);
296 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
297 call_wrapper
, gdb_get_tracepoint_list
, NULL
);
298 Tcl_CreateObjCommand (interp
, "gdb_pc_reg", call_wrapper
, get_pc_register
, NULL
);
299 Tcl_CreateObjCommand (interp
, "gdb_loadfile", call_wrapper
, gdb_loadfile
, NULL
);
300 Tcl_CreateObjCommand (gdbtk_interp
, "gdb_search", call_wrapper
,
302 Tcl_CreateObjCommand (interp
, "gdb_set_bp", call_wrapper
, gdb_set_bp
, NULL
);
303 Tcl_CreateObjCommand (interp
, "gdb_get_trace_frame_num",
304 call_wrapper
, gdb_get_trace_frame_num
, NULL
);
305 Tcl_CreateObjCommand (interp
, "gdb_stack", call_wrapper
, gdb_stack
, NULL
);
307 Tcl_LinkVar (interp
, "gdb_selected_frame_level",
308 (char *) &selected_frame_level
,
309 TCL_LINK_INT
| TCL_LINK_READ_ONLY
);
311 Tcl_PkgProvide(interp
, "Gdbtk", GDBTK_VERSION
);
315 /* This routine acts as a top-level for all GDB code called by Tcl/Tk. It
316 handles cleanups, and uses catch_errors to trap calls to return_to_top_level
318 This is necessary in order to prevent a longjmp out of the bowels of Tk,
319 possibly leaving things in a bad state. Since this routine can be called
320 recursively, it needs to save and restore the contents of the result_ptr as
324 call_wrapper (clientData
, interp
, objc
, objv
)
325 ClientData clientData
;
328 Tcl_Obj
*CONST objv
[];
330 struct wrapped_call_args wrapped_args
;
331 gdbtk_result new_result
, *old_result_ptr
;
333 old_result_ptr
= result_ptr
;
334 result_ptr
= &new_result
;
335 result_ptr
->obj_ptr
= Tcl_NewObj();
336 result_ptr
->flags
= GDBTK_TO_RESULT
;
338 wrapped_args
.func
= (Tcl_ObjCmdProc
*) clientData
;
339 wrapped_args
.interp
= interp
;
340 wrapped_args
.objc
= objc
;
341 wrapped_args
.objv
= objv
;
342 wrapped_args
.val
= TCL_OK
;
344 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
347 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
349 /* Make sure the timer interrupts are turned off. */
353 gdb_flush (gdb_stderr
); /* Flush error output */
354 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
356 /* If we errored out here, and the results were going to the
357 console, then gdbtk_fputs will have gathered the result into the
358 result_ptr. We also need to echo them out to the console here */
360 gdb_flush (gdb_stderr
); /* Flush error output */
361 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
363 /* In case of an error, we may need to force the GUI into idle
364 mode because gdbtk_call_command may have bombed out while in
365 the command routine. */
368 Tcl_Eval (interp
, "gdbtk_tcl_idle");
372 /* do not suppress any errors -- a remote target could have errored */
373 load_in_progress
= 0;
376 * Now copy the result over to the true Tcl result. If GDBTK_TO_RESULT flag
377 * bit is set , this just copies a null object over to the Tcl result, which is
378 * fine because we should reset the result in this case anyway.
380 if (result_ptr
->flags
& GDBTK_IN_TCL_RESULT
)
382 Tcl_DecrRefCount(result_ptr
->obj_ptr
);
386 Tcl_SetObjResult (interp
, result_ptr
->obj_ptr
);
389 result_ptr
= old_result_ptr
;
395 return wrapped_args
.val
;
399 * This is the wrapper that is passed to catch_errors.
403 wrapped_call (opaque_args
)
406 struct wrapped_call_args
*args
= (struct wrapped_call_args
*) opaque_args
;
407 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->objc
, args
->objv
);
411 /* This is a convenience function to sprintf something(s) into a
412 * new element in a Tcl list object.
416 #ifdef ANSI_PROTOTYPES
417 sprintf_append_element_to_obj (Tcl_Obj
*objp
, char *format
, ...)
419 sprintf_append_element_to_obj (va_alist
)
426 #ifdef ANSI_PROTOTYPES
427 va_start (args
, format
);
433 dsp
= va_arg (args
, Tcl_Obj
*);
434 format
= va_arg (args
, char *);
437 vsprintf (buf
, format
, args
);
439 Tcl_ListObjAppendElement (NULL
, objp
, Tcl_NewStringObj (buf
, -1));
443 * This section contains the commands that control execution.
446 /* This implements the tcl command gdb_clear_file.
448 * Prepare to accept a new executable file. This is called when we
449 * want to clear away everything we know about the old file, without
450 * asking the user. The Tcl code will have already asked the user if
451 * necessary. After this is called, we should be able to run the
452 * `file' command without getting any questions.
461 gdb_clear_file (clientData
, interp
, objc
, objv
)
462 ClientData clientData
;
465 Tcl_Obj
*CONST objv
[];
468 Tcl_SetStringObj (result_ptr
->obj_ptr
,
469 "Wrong number of args, none are allowed.", -1);
471 if (inferior_pid
!= 0 && target_has_execution
)
474 target_detach (NULL
, 0);
479 if (target_has_execution
)
482 symbol_file_command (NULL
, 0);
484 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
485 clear it here. FIXME: This seems like an abstraction violation
492 /* This implements the tcl command gdb_confirm_quit
493 * Ask the user to confirm an exit request.
498 * A boolean, 1 if the user answered yes, 0 if no.
502 gdb_confirm_quit (clientData
, interp
, objc
, objv
)
503 ClientData clientData
;
506 Tcl_Obj
*CONST objv
[];
512 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
516 ret
= quit_confirm ();
517 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, ret
);
521 /* This implements the tcl command gdb_force_quit
522 * Quit without asking for confirmation.
531 gdb_force_quit (clientData
, interp
, objc
, objv
)
532 ClientData clientData
;
535 Tcl_Obj
*CONST objv
[];
539 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
543 quit_force ((char *) NULL
, 1);
547 /* This implements the tcl command gdb_stop
548 * It stops the target in a continuable fashion.
557 gdb_stop (clientData
, interp
, objc
, objv
)
558 ClientData clientData
;
561 Tcl_Obj
*CONST objv
[];
568 quit_flag
= 1; /* hope something sees this */
575 * This section contains Tcl commands that are wrappers for invoking
576 * the GDB command interpreter.
580 /* This implements the tcl command `gdb_eval'.
581 * It uses the gdb evaluator to return the value of
582 * an expression in the current language
585 * expression - the expression to evaluate.
587 * The result of the evaluation.
591 gdb_eval (clientData
, interp
, objc
, objv
)
592 ClientData clientData
;
595 Tcl_Obj
*CONST objv
[];
597 struct expression
*expr
;
598 struct cleanup
*old_chain
=NULL
;
603 Tcl_SetStringObj (result_ptr
->obj_ptr
,
604 "wrong # args, should be \"gdb_eval expression\"", -1);
608 expr
= parse_expression (Tcl_GetStringFromObj (objv
[1], NULL
));
610 old_chain
= make_cleanup (free_current_contents
, &expr
);
612 val
= evaluate_expression (expr
);
615 * Print the result of the expression evaluation. This will go to
616 * eventually go to gdbtk_fputs, and from there be collected into
620 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
621 gdb_stdout
, 0, 0, 0, 0);
623 do_cleanups (old_chain
);
628 /* This implements the tcl command "gdb_cmd".
630 * It sends its argument to the GDB command scanner for execution.
631 * This command will never cause the update, idle and busy hooks to be called
635 * command - The GDB command to execute
637 * The output from the gdb command (except for the "load" & "while"
638 * which dump their output to the console.
642 gdb_cmd (clientData
, interp
, objc
, objv
)
643 ClientData clientData
;
646 Tcl_Obj
*CONST objv
[];
651 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
655 if (running_now
|| load_in_progress
)
660 /* for the load instruction (and possibly others later) we
661 set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
662 will not buffer all the data until the command is finished. */
664 if ((strncmp ("load ", Tcl_GetStringFromObj (objv
[1], NULL
), 5) == 0)
665 || (strncmp ("while ", Tcl_GetStringFromObj (objv
[1], NULL
), 6) == 0))
667 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
668 load_in_progress
= 1;
669 gdbtk_start_timer ();
672 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
674 if (load_in_progress
)
677 load_in_progress
= 0;
678 result_ptr
->flags
|= GDBTK_TO_RESULT
;
681 bpstat_do_actions (&stop_bpstat
);
687 * This implements the tcl command "gdb_immediate"
689 * It does exactly the same thing as gdb_cmd, except NONE of its outut
690 * is buffered. This will also ALWAYS cause the busy, update, and idle hooks to
691 * be called, contrasted with gdb_cmd, which NEVER calls them.
692 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
693 * to the console window.
696 * command - The GDB command to execute
702 gdb_immediate_command (clientData
, interp
, objc
, objv
)
703 ClientData clientData
;
706 Tcl_Obj
*CONST objv
[];
711 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
715 if (running_now
|| load_in_progress
)
720 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
722 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
724 bpstat_do_actions (&stop_bpstat
);
726 result_ptr
->flags
|= GDBTK_TO_RESULT
;
731 /* This implements the tcl command "gdb_prompt"
733 * It returns the gdb interpreter's prompt.
742 gdb_prompt_command (clientData
, interp
, objc
, objv
)
743 ClientData clientData
;
746 Tcl_Obj
*CONST objv
[];
748 Tcl_SetStringObj (result_ptr
->obj_ptr
, get_prompt (), -1);
754 * This section contains general informational commands.
757 /* This implements the tcl command "gdb_target_has_execution"
759 * Tells whether the target is executing.
764 * A boolean indicating whether the target is executing.
768 gdb_target_has_execution_command (clientData
, interp
, objc
, objv
)
769 ClientData clientData
;
772 Tcl_Obj
*CONST objv
[];
776 if (target_has_execution
&& inferior_pid
!= 0)
779 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, result
);
783 /* This implements the tcl command "gdb_load_info"
785 * It returns information about the file about to be downloaded.
788 * filename: The file to open & get the info on.
790 * A list consisting of the name and size of each section.
794 gdb_load_info (clientData
, interp
, objc
, objv
)
795 ClientData clientData
;
798 Tcl_Obj
*CONST objv
[];
801 struct cleanup
*old_cleanups
;
805 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
807 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
808 if (loadfile_bfd
== NULL
)
810 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Open failed", -1);
813 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
815 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
817 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Bad Object File", -1);
821 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
823 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
825 if (s
->flags
& SEC_LOAD
)
827 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
830 ob
[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd
, s
), -1);
831 ob
[1] = Tcl_NewLongObj ((long) size
);
832 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewListObj (2, ob
));
837 do_cleanups (old_cleanups
);
843 * This and gdb_get_locals just call gdb_get_vars_command with the right
844 * value of clientData. We can't use the client data in the definition
845 * of the command, because the call wrapper uses this instead...
849 gdb_get_locals_command (clientData
, interp
, objc
, objv
)
850 ClientData clientData
;
853 Tcl_Obj
*CONST objv
[];
856 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
861 gdb_get_args_command (clientData
, interp
, objc
, objv
)
862 ClientData clientData
;
865 Tcl_Obj
*CONST objv
[];
868 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
872 /* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
874 * This function sets the Tcl interpreter's result to a list of variable names
875 * depending on clientData. If clientData is one, the result is a list of
876 * arguments; zero returns a list of locals -- all relative to the block
877 * specified as an argument to the command. Valid commands include
878 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
882 * block - the address within which to specify the locals or args.
884 * A list of the locals or args
888 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
889 ClientData clientData
;
892 Tcl_Obj
*CONST objv
[];
894 struct symtabs_and_lines sals
;
897 char **canonical
, *args
;
898 int i
, nsyms
, arguments
;
902 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
,
903 "wrong # of args: should be \"",
904 Tcl_GetStringFromObj (objv
[0], NULL
),
905 " function:line|function|line|*addr\"", NULL
);
909 arguments
= (int) clientData
;
910 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
911 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
914 Tcl_SetStringObj (result_ptr
->obj_ptr
,
915 "error decoding line", -1);
919 /* Initialize the result pointer to an empty list. */
921 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
923 /* Resolve all line numbers to PC's */
924 for (i
= 0; i
< sals
.nelts
; i
++)
925 resolve_sal_pc (&sals
.sals
[i
]);
927 block
= block_for_pc (sals
.sals
[0].pc
);
930 nsyms
= BLOCK_NSYMS (block
);
931 for (i
= 0; i
< nsyms
; i
++)
933 sym
= BLOCK_SYM (block
, i
);
934 switch (SYMBOL_CLASS (sym
)) {
936 case LOC_UNDEF
: /* catches errors */
937 case LOC_CONST
: /* constant */
938 case LOC_STATIC
: /* static */
939 case LOC_REGISTER
: /* register */
940 case LOC_TYPEDEF
: /* local typedef */
941 case LOC_LABEL
: /* local label */
942 case LOC_BLOCK
: /* local function */
943 case LOC_CONST_BYTES
: /* loc. byte seq. */
944 case LOC_UNRESOLVED
: /* unresolved static */
945 case LOC_OPTIMIZED_OUT
: /* optimized out */
947 case LOC_ARG
: /* argument */
948 case LOC_REF_ARG
: /* reference arg */
949 case LOC_REGPARM
: /* register arg */
950 case LOC_REGPARM_ADDR
: /* indirect register arg */
951 case LOC_LOCAL_ARG
: /* stack arg */
952 case LOC_BASEREG_ARG
: /* basereg arg */
954 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
955 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
957 case LOC_LOCAL
: /* stack local */
958 case LOC_BASEREG
: /* basereg local */
960 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
961 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
965 if (BLOCK_FUNCTION (block
))
968 block
= BLOCK_SUPERBLOCK (block
);
974 /* This implements the tcl command "gdb_get_line"
976 * It returns the linenumber for a given linespec. It will take any spec
977 * that can be passed to decode_line_1
980 * linespec - the line specification
982 * The line number for that spec.
985 gdb_get_line_command (clientData
, interp
, objc
, objv
)
986 ClientData clientData
;
989 Tcl_Obj
*CONST objv
[];
991 struct symtabs_and_lines sals
;
992 char *args
, **canonical
;
996 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
997 Tcl_GetStringFromObj (objv
[0], NULL
),
998 " linespec\"", NULL
);
1002 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1003 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1004 if (sals
.nelts
== 1)
1006 Tcl_SetIntObj (result_ptr
->obj_ptr
, sals
.sals
[0].line
);
1010 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1015 /* This implements the tcl command "gdb_get_file"
1017 * It returns the file containing a given line spec.
1020 * linespec - The linespec to look up
1022 * The file containing it.
1026 gdb_get_file_command (clientData
, interp
, objc
, objv
)
1027 ClientData clientData
;
1030 Tcl_Obj
*CONST objv
[];
1032 struct symtabs_and_lines sals
;
1033 char *args
, **canonical
;
1037 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1038 Tcl_GetStringFromObj (objv
[0], NULL
),
1039 " linespec\"", NULL
);
1043 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1044 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1045 if (sals
.nelts
== 1)
1047 Tcl_SetStringObj (result_ptr
->obj_ptr
, sals
.sals
[0].symtab
->filename
, -1);
1051 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1055 /* This implements the tcl command "gdb_get_function"
1057 * It finds the function containing the given line spec.
1060 * linespec - The line specification
1062 * The function that contains it, or "N/A" if it is not in a function.
1065 gdb_get_function_command (clientData
, interp
, objc
, objv
)
1066 ClientData clientData
;
1069 Tcl_Obj
*CONST objv
[];
1072 struct symtabs_and_lines sals
;
1073 char *args
, **canonical
;
1077 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1078 Tcl_GetStringFromObj (objv
[0], NULL
),
1079 " linespec\"", NULL
);
1083 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1084 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1085 if (sals
.nelts
== 1)
1087 resolve_sal_pc (&sals
.sals
[0]);
1088 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
1089 if (function
!= NULL
)
1091 Tcl_SetStringObj (result_ptr
->obj_ptr
, function
, -1);
1096 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1100 /* This implements the tcl command "gdb_find_file"
1102 * It searches the symbol tables to get the full pathname to a file.
1105 * filename: the file name to search for.
1107 * The full path to the file, or an empty string if the file is not
1112 gdb_find_file_command (clientData
, interp
, objc
, objv
)
1113 ClientData clientData
;
1116 Tcl_Obj
*CONST objv
[];
1118 char *filename
= NULL
;
1123 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
1127 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1129 filename
= st
->fullname
;
1131 if (filename
== NULL
)
1132 Tcl_SetStringObj (result_ptr
->obj_ptr
, "", 0);
1134 Tcl_SetStringObj (result_ptr
->obj_ptr
, filename
, -1);
1139 /* This implements the tcl command "gdb_listfiles"
1141 * This lists all the files in the current executible.
1143 * Note that this currently pulls in all sorts of filenames
1144 * that aren't really part of the executable. It would be
1145 * best if we could check each file to see if it actually
1146 * contains executable lines of code, but we can't do that
1150 * ?pathname? - If provided, only files which match pathname
1151 * (up to strlen(pathname)) are included. THIS DOES NOT
1152 * CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1153 * THE FULL PATHNAME!!!
1156 * A list of all matching files.
1159 gdb_listfiles (clientData
, interp
, objc
, objv
)
1160 ClientData clientData
;
1163 Tcl_Obj
*CONST objv
[];
1165 struct objfile
*objfile
;
1166 struct partial_symtab
*psymtab
;
1167 struct symtab
*symtab
;
1168 char *lastfile
, *pathname
=NULL
, **files
;
1170 int i
, numfiles
= 0, len
= 0;
1173 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1177 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1181 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1183 ALL_PSYMTABS (objfile
, psymtab
)
1185 if (numfiles
== files_size
)
1187 files_size
= files_size
* 2;
1188 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1190 if (psymtab
->filename
)
1192 if (!len
|| !strncmp(pathname
, psymtab
->filename
,len
)
1193 || !strcmp(psymtab
->filename
, basename(psymtab
->filename
)))
1195 files
[numfiles
++] = basename(psymtab
->filename
);
1200 ALL_SYMTABS (objfile
, symtab
)
1202 if (numfiles
== files_size
)
1204 files_size
= files_size
* 2;
1205 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1207 if (symtab
->filename
&& symtab
->linetable
&& symtab
->linetable
->nitems
)
1209 if (!len
|| !strncmp(pathname
, symtab
->filename
,len
)
1210 || !strcmp(symtab
->filename
, basename(symtab
->filename
)))
1212 files
[numfiles
++] = basename(symtab
->filename
);
1217 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1221 /* Discard the old result pointer, in case it has accumulated anything
1222 and set it to a new list object */
1224 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1226 for (i
= 0; i
< numfiles
; i
++)
1228 if (strcmp(files
[i
],lastfile
))
1229 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj(files
[i
], -1));
1230 lastfile
= files
[i
];
1238 comp_files (file1
, file2
)
1239 const void *file1
, *file2
;
1241 return strcmp(* (char **) file1
, * (char **) file2
);
1245 /* This implements the tcl command "gdb_search"
1249 * option - One of "functions", "variables" or "types"
1250 * regexp - The regular expression to look for.
1259 gdb_search (clientData
, interp
, objc
, objv
)
1260 ClientData clientData
;
1263 Tcl_Obj
*CONST objv
[];
1265 struct symbol_search
*ss
= NULL
;
1266 struct symbol_search
*p
;
1267 struct cleanup
*old_chain
= NULL
;
1268 Tcl_Obj
*CONST
*switch_objv
;
1269 int index
, switch_objc
, i
;
1270 namespace_enum space
= 0;
1272 int static_only
, nfiles
;
1273 Tcl_Obj
**file_list
;
1275 static char *search_options
[] = { "functions", "variables", "types", (char *) NULL
};
1276 static char *switches
[] = { "-files", "-static", (char *) NULL
};
1277 enum search_opts
{ SEARCH_FUNCTIONS
, SEARCH_VARIABLES
, SEARCH_TYPES
};
1278 enum switches_opts
{ SWITCH_FILES
, SWITCH_STATIC_ONLY
};
1282 Tcl_WrongNumArgs (interp
, 1, objv
, "option regexp ?arg ...?");
1283 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1287 if (Tcl_GetIndexFromObj (interp
, objv
[1], search_options
, "option", 0,
1290 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1294 /* Unfortunately, we cannot teach search_symbols to search on
1295 multiple regexps, so we have to do a two-tier search for
1296 any searches which choose to narrow the playing field. */
1297 switch ((enum search_opts
) index
)
1299 case SEARCH_FUNCTIONS
:
1300 space
= FUNCTIONS_NAMESPACE
; break;
1301 case SEARCH_VARIABLES
:
1302 space
= VARIABLES_NAMESPACE
; break;
1304 space
= TYPES_NAMESPACE
; break;
1307 regexp
= Tcl_GetStringFromObj (objv
[2], NULL
);
1308 /* Process any switches that refine the search */
1309 switch_objc
= objc
- 3;
1310 switch_objv
= objv
+ 3;
1314 files
= (char **) NULL
;
1315 while (switch_objc
> 0)
1317 if (Tcl_GetIndexFromObj (interp
, switch_objv
[0], switches
,
1318 "option", 0, &index
) != TCL_OK
)
1320 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1324 switch ((enum switches_opts
) index
)
1329 if (switch_objc
< 2)
1331 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList -static 1|0]");
1332 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1335 result
= Tcl_ListObjGetElements (interp
, switch_objv
[1], &nfiles
, &file_list
);
1336 if (result
!= TCL_OK
)
1339 files
= (char **) xmalloc (nfiles
* sizeof (char *));
1340 for (i
= 0; i
< nfiles
; i
++)
1341 files
[i
] = Tcl_GetStringFromObj (file_list
[i
], NULL
);
1346 case SWITCH_STATIC_ONLY
:
1347 if (switch_objc
< 2)
1349 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList] [-static 1|0]");
1350 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1353 if ( Tcl_GetBooleanFromObj (interp
, switch_objv
[1], &static_only
) !=
1355 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1365 search_symbols (regexp
, space
, nfiles
, files
, &ss
);
1367 old_chain
= make_cleanup (free_search_symbols
, ss
);
1369 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1371 for (p
= ss
; p
!= NULL
; p
= p
->next
)
1375 if (static_only
&& p
->block
!= STATIC_BLOCK
)
1378 elem
= Tcl_NewListObj (0, NULL
);
1380 if (p
->msymbol
== NULL
)
1381 Tcl_ListObjAppendElement (interp
, elem
,
1382 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->symbol
), -1));
1384 Tcl_ListObjAppendElement (interp
, elem
,
1385 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->msymbol
), -1));
1387 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, elem
);
1391 do_cleanups (old_chain
);
1396 /* This implements the tcl command gdb_listfuncs
1398 * It lists all the functions defined in a given file
1401 * file - the file to look in
1403 * A list of two element lists, the first element is
1404 * the symbol name, and the second is a boolean indicating
1405 * whether the symbol is demangled (1 for yes).
1409 gdb_listfuncs (clientData
, interp
, objc
, objv
)
1410 ClientData clientData
;
1413 Tcl_Obj
*CONST objv
[];
1415 struct symtab
*symtab
;
1416 struct blockvector
*bv
;
1420 Tcl_Obj
*funcVals
[2];
1424 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1427 symtab
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1430 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No such file", -1);
1434 if (mangled
== NULL
)
1436 mangled
= Tcl_NewBooleanObj(1);
1437 not_mangled
= Tcl_NewBooleanObj(0);
1438 Tcl_IncrRefCount(mangled
);
1439 Tcl_IncrRefCount(not_mangled
);
1442 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1444 bv
= BLOCKVECTOR (symtab
);
1445 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1447 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1448 /* Skip the sort if this block is always sorted. */
1449 if (!BLOCK_SHOULD_SORT (b
))
1450 sort_block_syms (b
);
1451 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1453 sym
= BLOCK_SYM (b
, j
);
1454 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1457 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1460 /* strip out "global constructors" and "global destructors" */
1461 /* because we aren't interested in them. */
1462 if (strncmp (name
, "global ", 7))
1464 funcVals
[0] = Tcl_NewStringObj(name
, -1);
1465 funcVals
[1] = mangled
;
1470 funcVals
[0] = Tcl_NewStringObj(SYMBOL_NAME(sym
), -1);
1471 funcVals
[1] = not_mangled
;
1473 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1474 Tcl_NewListObj (2, funcVals
));
1483 * This section contains all the commands that act on the registers:
1486 /* This is a sort of mapcar function for operations on registers */
1489 map_arg_registers (objc
, objv
, func
, argp
)
1491 Tcl_Obj
*CONST objv
[];
1492 void (*func
) PARAMS ((int regnum
, void *argp
));
1497 /* Note that the test for a valid register must include checking the
1498 reg_names array because NUM_REGS may be allocated for the union of the
1499 register sets within a family of related processors. In this case, the
1500 trailing entries of reg_names will change depending upon the particular
1501 processor being debugged. */
1503 if (objc
== 0) /* No args, just do all the regs */
1507 && reg_names
[regnum
] != NULL
1508 && *reg_names
[regnum
] != '\000';
1510 func (regnum
, argp
);
1515 /* Else, list of register #s, just do listed regs */
1516 for (; objc
> 0; objc
--, objv
++)
1519 if (Tcl_GetIntFromObj (NULL
, *objv
, ®num
) != TCL_OK
) {
1520 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1525 && regnum
< NUM_REGS
1526 && reg_names
[regnum
] != NULL
1527 && *reg_names
[regnum
] != '\000')
1528 func (regnum
, argp
);
1531 Tcl_SetStringObj (result_ptr
->obj_ptr
, "bad register number", -1);
1539 /* This implements the TCL command `gdb_regnames', which returns a list of
1540 all of the register names. */
1543 gdb_regnames (clientData
, interp
, objc
, objv
)
1544 ClientData clientData
;
1547 Tcl_Obj
*CONST objv
[];
1552 return map_arg_registers (objc
, objv
, get_register_name
, NULL
);
1556 get_register_name (regnum
, argp
)
1558 void *argp
; /* Ignored */
1560 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1561 Tcl_NewStringObj (reg_names
[regnum
], -1));
1564 /* This implements the tcl command gdb_fetch_registers
1565 * Pass it a list of register names, and it will
1566 * return their values as a list.
1569 * format: The format string for printing the values
1570 * args: the registers to look for
1572 * A list of their values.
1576 gdb_fetch_registers (clientData
, interp
, objc
, objv
)
1577 ClientData clientData
;
1580 Tcl_Obj
*CONST objv
[];
1586 Tcl_SetStringObj (result_ptr
->obj_ptr
,
1587 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
1591 format
= *(Tcl_GetStringFromObj(objv
[0], NULL
));
1595 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Output the results as a list */
1596 result
= map_arg_registers (objc
, objv
, get_register
, (void *) format
);
1597 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
1603 get_register (regnum
, fp
)
1607 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1608 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
1609 int format
= (int)fp
;
1614 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1616 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1617 Tcl_NewStringObj ("Optimized out", -1));
1621 /* Convert raw data to virtual format if necessary. */
1623 if (REGISTER_CONVERTIBLE (regnum
))
1625 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
1626 raw_buffer
, virtual_buffer
);
1629 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1634 printf_filtered ("0x");
1635 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1637 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1638 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1639 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
1643 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
1644 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1648 /* This implements the tcl command get_pc_reg
1649 * It returns the value of the PC register
1654 * The value of the pc register.
1658 get_pc_register (clientData
, interp
, objc
, objv
)
1659 ClientData clientData
;
1662 Tcl_Obj
*CONST objv
[];
1666 sprintf (buff
, "0x%llx",(long long) read_register (PC_REGNUM
));
1667 Tcl_SetStringObj(result_ptr
->obj_ptr
, buff
, -1);
1671 /* This implements the tcl command "gdb_changed_register_list"
1672 * It takes a list of registers, and returns a list of
1673 * the registers on that list that have changed since the last
1674 * time the proc was called.
1677 * A list of registers.
1679 * A list of changed registers.
1683 gdb_changed_register_list (clientData
, interp
, objc
, objv
)
1684 ClientData clientData
;
1687 Tcl_Obj
*CONST objv
[];
1692 return map_arg_registers (objc
, objv
, register_changed_p
, NULL
);
1696 register_changed_p (regnum
, argp
)
1698 void *argp
; /* Ignored */
1700 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1702 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1705 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1706 REGISTER_RAW_SIZE (regnum
)) == 0)
1709 /* Found a changed register. Save new value and return its number. */
1711 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1712 REGISTER_RAW_SIZE (regnum
));
1714 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(regnum
));
1718 * This section contains the commands that deal with tracepoints:
1721 /* return a list of all tracepoint numbers in interpreter */
1723 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
1724 ClientData clientData
;
1727 Tcl_Obj
*CONST objv
[];
1729 struct tracepoint
*tp
;
1731 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1733 ALL_TRACEPOINTS (tp
)
1734 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->number
));
1739 /* returns -1 if not found, tracepoint # if found */
1741 tracepoint_exists (char * args
)
1743 struct tracepoint
*tp
;
1745 struct symtabs_and_lines sals
;
1749 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1750 if (sals
.nelts
== 1)
1752 resolve_sal_pc (&sals
.sals
[0]);
1753 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
1754 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
1757 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
1758 strcat (file
, sals
.sals
[0].symtab
->filename
);
1760 ALL_TRACEPOINTS (tp
)
1762 if (tp
->address
== sals
.sals
[0].pc
)
1763 result
= tp
->number
;
1765 /* Why is this here? This messes up assembly traces */
1766 else if (tp
->source_file
!= NULL
1767 && strcmp (tp
->source_file
, file
) == 0
1768 && sals
.sals
[0].line
== tp
->line_number
)
1769 result
= tp
->number
;
1780 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
1781 ClientData clientData
;
1784 Tcl_Obj
*CONST objv
[];
1790 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1791 Tcl_GetStringFromObj (objv
[0], NULL
),
1792 " function:line|function|line|*addr\"", NULL
);
1796 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1798 Tcl_SetIntObj (result_ptr
->obj_ptr
, tracepoint_exists (args
));
1803 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
1804 ClientData clientData
;
1807 Tcl_Obj
*CONST objv
[];
1809 struct symtab_and_line sal
;
1811 struct tracepoint
*tp
;
1812 struct action_line
*al
;
1813 Tcl_Obj
*action_list
;
1814 char *filename
, *funcname
;
1819 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1823 if (Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
) != TCL_OK
)
1825 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1829 ALL_TRACEPOINTS (tp
)
1830 if (tp
->number
== tpnum
)
1835 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Tracepoint #%d does not exist", -1);
1839 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1840 sal
= find_pc_line (tp
->address
, 0);
1841 filename
= symtab_to_filename (sal
.symtab
);
1842 if (filename
== NULL
)
1844 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1845 Tcl_NewStringObj (filename
, -1));
1846 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
1847 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (funcname
, -1));
1848 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (sal
.line
));
1849 sprintf (tmp
, "0x%lx", tp
->address
);
1850 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (tmp
, -1));
1851 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->enabled
));
1852 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->pass_count
));
1853 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->step_count
));
1854 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->thread
));
1855 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->hit_count
));
1857 /* Append a list of actions */
1858 action_list
= Tcl_NewObj ();
1859 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
1861 Tcl_ListObjAppendElement (interp
, action_list
,
1862 Tcl_NewStringObj (al
->action
, -1));
1864 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, action_list
);
1871 gdb_trace_status (clientData
, interp
, objc
, objv
)
1872 ClientData clientData
;
1875 Tcl_Obj
*CONST objv
[];
1879 if (trace_running_p
)
1882 Tcl_SetIntObj (result_ptr
->obj_ptr
, result
);
1889 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
1890 ClientData clientData
;
1893 Tcl_Obj
*CONST objv
[];
1897 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1898 Tcl_GetStringFromObj (objv
[0], NULL
),
1899 " linespec\"", NULL
);
1903 Tcl_SetIntObj (result_ptr
->obj_ptr
, get_traceframe_number ());
1908 /* This implements the tcl command gdb_actions
1909 * It sets actions for a given tracepoint.
1912 * number: the tracepoint in question
1913 * actions: the actions to add to this tracepoint
1919 gdb_actions_command (clientData
, interp
, objc
, objv
)
1920 ClientData clientData
;
1923 Tcl_Obj
*CONST objv
[];
1925 struct tracepoint
*tp
;
1927 int nactions
, i
, len
;
1928 char *number
, *args
, *action
;
1930 struct action_line
*next
= NULL
, *temp
;
1931 enum actionline_type linetype
;
1935 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # args: should be: \"",
1936 Tcl_GetStringFromObj (objv
[0], NULL
),
1937 " number actions\"", NULL
);
1941 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
1942 tp
= get_tracepoint_by_number (&args
);
1945 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "Tracepoint \"", number
, "\" does not exist", NULL
);
1949 /* Free any existing actions */
1950 if (tp
->actions
!= NULL
)
1955 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
1957 /* Add the actions to the tracepoint */
1958 for (i
= 0; i
< nactions
; i
++)
1960 temp
= xmalloc (sizeof (struct action_line
));
1962 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
1963 temp
->action
= savestring (action
, len
);
1965 linetype
= validate_actionline (&(temp
->action
), tp
);
1967 if (linetype
== BADLINE
)
1989 * This section has commands that handle source disassembly.
1992 /* This implements the tcl command gdb_disassemble
1995 * source_with_assm - must be "source" or "nosource"
1996 * low_address - the address from which to start disassembly
1997 * ?hi_address? - the address to which to disassemble, defaults
1998 * to the end of the function containing low_address.
2000 * The disassembled code is passed to fputs_unfiltered, so it
2001 * either goes to the console if result_ptr->obj_ptr is NULL or to
2006 gdb_disassemble (clientData
, interp
, objc
, objv
)
2007 ClientData clientData
;
2010 Tcl_Obj
*CONST objv
[];
2012 CORE_ADDR pc
, low
, high
;
2013 int mixed_source_and_assembly
;
2014 static disassemble_info di
;
2015 static int di_initialized
;
2018 if (objc
!= 3 && objc
!= 4)
2019 error ("wrong # args");
2021 if (! di_initialized
)
2023 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
2024 (fprintf_ftype
) fprintf_unfiltered
);
2025 di
.flavour
= bfd_target_unknown_flavour
;
2026 di
.memory_error_func
= dis_asm_memory_error
;
2027 di
.print_address_func
= dis_asm_print_address
;
2031 di
.mach
= tm_print_insn_info
.mach
;
2032 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
2033 di
.endian
= BFD_ENDIAN_BIG
;
2035 di
.endian
= BFD_ENDIAN_LITTLE
;
2037 arg_ptr
= Tcl_GetStringFromObj (objv
[1], NULL
);
2038 if (*arg_ptr
== 's' && strcmp (arg_ptr
, "source") == 0)
2039 mixed_source_and_assembly
= 1;
2040 else if (*arg_ptr
== 'n' && strcmp (arg_ptr
, "nosource") == 0)
2041 mixed_source_and_assembly
= 0;
2043 error ("First arg must be 'source' or 'nosource'");
2045 low
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[2], NULL
));
2049 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
2050 error ("No function contains specified address");
2053 high
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[3], NULL
));
2055 /* If disassemble_from_exec == -1, then we use the following heuristic to
2056 determine whether or not to do disassembly from target memory or from the
2059 If we're debugging a local process, read target memory, instead of the
2060 exec file. This makes disassembly of functions in shared libs work
2063 Else, we're debugging a remote process, and should disassemble from the
2064 exec file for speed. However, this is no good if the target modifies its
2065 code (for relocation, or whatever).
2068 if (disassemble_from_exec
== -1)
2070 if (strcmp (target_shortname
, "child") == 0
2071 || strcmp (target_shortname
, "procfs") == 0
2072 || strcmp (target_shortname
, "vxprocess") == 0)
2073 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
2075 disassemble_from_exec
= 1; /* It's remote, read the exec file */
2078 if (disassemble_from_exec
)
2079 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
2081 di
.read_memory_func
= dis_asm_read_memory
;
2083 /* If just doing straight assembly, all we need to do is disassemble
2084 everything between low and high. If doing mixed source/assembly, we've
2085 got a totally different path to follow. */
2087 if (mixed_source_and_assembly
)
2088 { /* Come here for mixed source/assembly */
2089 /* The idea here is to present a source-O-centric view of a function to
2090 the user. This means that things are presented in source order, with
2091 (possibly) out of order assembly immediately following. */
2092 struct symtab
*symtab
;
2093 struct linetable_entry
*le
;
2096 struct my_line_entry
*mle
;
2097 struct symtab_and_line sal
;
2102 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
2107 /* First, convert the linetable to a bunch of my_line_entry's. */
2109 le
= symtab
->linetable
->item
;
2110 nlines
= symtab
->linetable
->nitems
;
2115 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
2119 /* Copy linetable entries for this function into our data structure, creating
2120 end_pc's and setting out_of_order as appropriate. */
2122 /* First, skip all the preceding functions. */
2124 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
2126 /* Now, copy all entries before the end of this function. */
2129 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
2131 if (le
[i
].line
== le
[i
+ 1].line
2132 && le
[i
].pc
== le
[i
+ 1].pc
)
2133 continue; /* Ignore duplicates */
2135 mle
[newlines
].line
= le
[i
].line
;
2136 if (le
[i
].line
> le
[i
+ 1].line
)
2138 mle
[newlines
].start_pc
= le
[i
].pc
;
2139 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
2143 /* If we're on the last line, and it's part of the function, then we need to
2144 get the end pc in a special way. */
2149 mle
[newlines
].line
= le
[i
].line
;
2150 mle
[newlines
].start_pc
= le
[i
].pc
;
2151 sal
= find_pc_line (le
[i
].pc
, 0);
2152 mle
[newlines
].end_pc
= sal
.end
;
2156 /* Now, sort mle by line #s (and, then by addresses within lines). */
2159 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
2161 /* Now, for each line entry, emit the specified lines (unless they have been
2162 emitted before), followed by the assembly code for that line. */
2164 next_line
= 0; /* Force out first line */
2165 for (i
= 0; i
< newlines
; i
++)
2167 /* Print out everything from next_line to the current line. */
2169 if (mle
[i
].line
>= next_line
)
2172 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
2174 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
2176 next_line
= mle
[i
].line
+ 1;
2179 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
2182 fputs_unfiltered (" ", gdb_stdout
);
2183 print_address (pc
, gdb_stdout
);
2184 fputs_unfiltered (":\t ", gdb_stdout
);
2185 pc
+= (*tm_print_insn
) (pc
, &di
);
2186 fputs_unfiltered ("\n", gdb_stdout
);
2193 for (pc
= low
; pc
< high
; )
2196 fputs_unfiltered (" ", gdb_stdout
);
2197 print_address (pc
, gdb_stdout
);
2198 fputs_unfiltered (":\t ", gdb_stdout
);
2199 pc
+= (*tm_print_insn
) (pc
, &di
);
2200 fputs_unfiltered ("\n", gdb_stdout
);
2204 gdb_flush (gdb_stdout
);
2209 /* This is the memory_read_func for gdb_disassemble when we are
2210 disassembling from the exec file. */
2213 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
2217 disassemble_info
*info
;
2219 extern struct target_ops exec_ops
;
2223 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
2234 /* This will be passed to qsort to sort the results of the disassembly */
2237 compare_lines (mle1p
, mle2p
)
2241 struct my_line_entry
*mle1
, *mle2
;
2244 mle1
= (struct my_line_entry
*) mle1p
;
2245 mle2
= (struct my_line_entry
*) mle2p
;
2247 val
= mle1
->line
- mle2
->line
;
2252 return mle1
->start_pc
- mle2
->start_pc
;
2255 /* This implements the TCL command `gdb_loc',
2258 * ?symbol? The symbol or address to locate - defaults to pc
2260 * a list consisting of the following:
2261 * basename, function name, filename, line number, address, current pc
2265 gdb_loc (clientData
, interp
, objc
, objv
)
2266 ClientData clientData
;
2269 Tcl_Obj
*CONST objv
[];
2272 struct symtab_and_line sal
;
2273 char *funcname
, *fname
;
2276 if (!have_full_symbols () && !have_partial_symbols ())
2278 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No symbol table is loaded", -1);
2284 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
2286 /* Note - this next line is not correct on all architectures. */
2287 /* For a graphical debugger we really want to highlight the */
2288 /* assembly line that called the next function on the stack. */
2289 /* Many architectures have the next instruction saved as the */
2290 /* pc on the stack, so what happens is the next instruction is hughlighted. */
2292 pc
= selected_frame
->pc
;
2293 sal
= find_pc_line (selected_frame
->pc
,
2294 selected_frame
->next
!= NULL
2295 && !selected_frame
->next
->signal_handler_caller
2296 && !frame_in_dummy (selected_frame
->next
));
2301 sal
= find_pc_line (stop_pc
, 0);
2306 struct symtabs_and_lines sals
;
2309 sals
= decode_line_spec (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
2315 if (sals
.nelts
!= 1)
2317 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Ambiguous line spec", -1);
2324 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
2329 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2330 Tcl_NewStringObj (sal
.symtab
->filename
, -1));
2332 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewStringObj ("", 0));
2334 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
2335 fname
= cplus_demangle (funcname
, 0);
2338 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2339 Tcl_NewStringObj (fname
, -1));
2343 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2344 Tcl_NewStringObj (funcname
, -1));
2346 filename
= symtab_to_filename (sal
.symtab
);
2347 if (filename
== NULL
)
2350 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2351 Tcl_NewStringObj (filename
, -1));
2352 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(sal
.line
)); /* line number */
2353 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
2354 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
2358 /* This implements the Tcl command 'gdb_get_mem', which
2359 * dumps a block of memory
2361 * gdb_get_mem addr form size num aschar
2363 * addr: address of data to dump
2364 * form: a char indicating format
2365 * size: size of each element; 1,2,4, or 8 bytes
2366 * num: the number of bytes to read
2367 * acshar: an optional ascii character to use in ASCII dump
2370 * a list of elements followed by an optional ASCII dump
2374 gdb_get_mem (clientData
, interp
, objc
, objv
)
2375 ClientData clientData
;
2378 Tcl_Obj
*CONST objv
[];
2380 int size
, asize
, i
, j
, bc
;
2382 int nbytes
, rnum
, bpr
;
2384 char format
, c
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
2385 struct type
*val_type
;
2387 if (objc
< 6 || objc
> 7)
2389 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2390 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2394 if (Tcl_GetIntFromObj (interp
, objv
[3], &size
) != TCL_OK
)
2396 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2401 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid size, must be > 0", -1);
2405 if (Tcl_GetIntFromObj (interp
, objv
[4], &nbytes
) != TCL_OK
)
2407 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2412 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid number of bytes, must be > 0",
2417 if (Tcl_GetIntFromObj (interp
, objv
[5], &bpr
) != TCL_OK
)
2419 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2424 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid bytes per row, must be > 0", -1);
2428 if (Tcl_GetLongFromObj (interp
, objv
[1], &tmp
) != TCL_OK
)
2431 addr
= (CORE_ADDR
) tmp
;
2433 format
= *(Tcl_GetStringFromObj (objv
[2], NULL
));
2434 mbuf
= (char *)malloc (nbytes
+32);
2437 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Out of memory.", -1);
2441 memset (mbuf
, 0, nbytes
+32);
2444 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
2447 aschar
= *(Tcl_GetStringFromObj(objv
[6], NULL
));
2453 val_type
= builtin_type_char
;
2457 val_type
= builtin_type_short
;
2461 val_type
= builtin_type_int
;
2465 val_type
= builtin_type_long_long
;
2469 val_type
= builtin_type_char
;
2473 bc
= 0; /* count of bytes in a row */
2474 buff
[0] = '"'; /* buffer for ascii dump */
2475 bptr
= &buff
[1]; /* pointer for ascii dump */
2477 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Build up the result as a list... */
2479 for (i
=0; i
< nbytes
; i
+= size
)
2483 fputs_unfiltered ("N/A ", gdb_stdout
);
2485 for ( j
= 0; j
< size
; j
++)
2490 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
2494 for ( j
= 0; j
< size
; j
++)
2497 if (c
< 32 || c
> 126)
2509 if (aschar
&& (bc
>= bpr
))
2511 /* end of row. print it and reset variables */
2516 fputs_unfiltered (buff
, gdb_stdout
);
2521 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
2529 /* This implements the tcl command "gdb_loadfile"
2530 * It loads a c source file into a text widget.
2533 * widget: the name of the text widget to fill
2534 * filename: the name of the file to load
2535 * linenumbers: A boolean indicating whether or not to display line numbers.
2540 /* In this routine, we will build up a "line table", i.e. a
2541 * table of bits showing which lines in the source file are executible.
2542 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2544 * Its size limits the maximum number of lines
2545 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2546 * the file is loaded, so it is OK to make this very large.
2547 * Additional memory will be allocated if needed. */
2548 #define LTABLE_SIZE 20000
2550 gdb_loadfile (clientData
, interp
, objc
, objv
)
2551 ClientData clientData
;
2554 Tcl_Obj
*CONST objv
[];
2556 char *file
, *widget
;
2557 int linenumbers
, ln
, lnum
, ltable_size
;
2560 struct symtab
*symtab
;
2561 struct linetable_entry
*le
;
2564 Tcl_DString text_cmd_1
, text_cmd_2
, *cur_cmd
;
2565 char line
[1024], line_num_buf
[16];
2566 int prefix_len_1
, prefix_len_2
, cur_prefix_len
, widget_len
;
2571 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
2575 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
2576 if ( Tk_NameToWindow (interp
, widget
, Tk_MainWindow (interp
)) == NULL
)
2581 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
2582 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
2584 if ((fp
= fopen ( file
, "r" )) == NULL
)
2586 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Can't open file for reading", -1);
2590 symtab
= full_lookup_symtab (file
);
2593 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "File not found in symtab", -1);
2598 if (stat (file
, &st
) < 0)
2600 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
2605 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
2606 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
2608 mtime
= bfd_get_mtime(exec_bfd
);
2610 if (mtime
&& mtime
< st
.st_mtime
)
2611 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2614 /* Source linenumbers don't appear to be in order, and a sort is */
2615 /* too slow so the fastest solution is just to allocate a huge */
2616 /* array and set the array entry for each linenumber */
2618 ltable_size
= LTABLE_SIZE
;
2619 ltable
= (char *)malloc (LTABLE_SIZE
);
2622 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2627 memset (ltable
, 0, LTABLE_SIZE
);
2629 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
2631 le
= symtab
->linetable
->item
;
2632 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
2634 lnum
= le
->line
>> 3;
2635 if (lnum
>= ltable_size
)
2638 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
2639 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
2641 if (new_ltable
== NULL
)
2643 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2648 ltable
= new_ltable
;
2650 ltable
[lnum
] |= 1 << (le
->line
% 8);
2654 Tcl_DStringInit(&text_cmd_1
);
2655 Tcl_DStringInit(&text_cmd_2
);
2659 widget_len
= strlen (widget
);
2662 Tcl_DStringAppend (&text_cmd_1
, widget
, widget_len
);
2663 Tcl_DStringAppend (&text_cmd_2
, widget
, widget_len
);
2667 Tcl_DStringAppend (&text_cmd_1
, " insert end {-\t", -1);
2668 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2670 Tcl_DStringAppend (&text_cmd_2
, " insert end { \t", -1);
2671 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2673 while (fgets (line
+ 1, 980, fp
))
2675 sprintf (line_num_buf
, "%d", ln
);
2676 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2678 cur_cmd
= &text_cmd_1
;
2679 cur_prefix_len
= prefix_len_1
;
2680 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2681 Tcl_DStringAppend (cur_cmd
, "} break_tag", 11);
2685 cur_cmd
= &text_cmd_2
;
2686 cur_prefix_len
= prefix_len_2
;
2687 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2688 Tcl_DStringAppend (cur_cmd
, "} \"\"", 4);
2691 Tcl_DStringAppendElement (cur_cmd
, line
);
2692 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2694 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2695 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2701 Tcl_DStringAppend (&text_cmd_1
, " insert end {- } break_tag", -1);
2702 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2703 Tcl_DStringAppend (&text_cmd_2
, " insert end { } \"\"", -1);
2704 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2707 while (fgets (line
+ 1, 980, fp
))
2709 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2711 cur_cmd
= &text_cmd_1
;
2712 cur_prefix_len
= prefix_len_1
;
2716 cur_cmd
= &text_cmd_2
;
2717 cur_prefix_len
= prefix_len_2
;
2720 Tcl_DStringAppendElement (cur_cmd
, line
);
2721 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2723 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2724 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2730 Tcl_DStringFree (&text_cmd_1
);
2731 Tcl_DStringFree (&text_cmd_2
);
2738 * This section contains commands for manipulation of breakpoints.
2742 /* set a breakpoint by source file and line number */
2743 /* flags are as follows: */
2744 /* least significant 2 bits are disposition, rest is */
2745 /* type (normally 0).
2748 bp_breakpoint, Normal breakpoint
2749 bp_hardware_breakpoint, Hardware assisted breakpoint
2752 Disposition of breakpoint. Ie: what to do after hitting it.
2755 del_at_next_stop, Delete at next stop, whether hit or not
2757 donttouch Leave it alone
2761 /* This implements the tcl command "gdb_set_bp"
2762 * It sets breakpoints, and runs the Tcl command
2763 * gdbtk_tcl_breakpoint create
2764 * to register the new breakpoint with the GUI.
2767 * filename: the file in which to set the breakpoint
2768 * line: the line number for the breakpoint
2769 * type: the type of the breakpoint
2771 * The return value of the call to gdbtk_tcl_breakpoint.
2775 gdb_set_bp (clientData
, interp
, objc
, objv
)
2776 ClientData clientData
;
2779 Tcl_Obj
*CONST objv
[];
2782 struct symtab_and_line sal
;
2783 int line
, flags
, ret
;
2784 struct breakpoint
*b
;
2790 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
2794 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
2795 if (sal
.symtab
== NULL
)
2798 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
2800 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2804 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
2806 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2811 if (!find_line_pc (sal
.symtab
, sal
.line
, &sal
.pc
))
2814 sal
.section
= find_pc_overlay (sal
.pc
);
2815 b
= set_raw_breakpoint (sal
);
2816 set_breakpoint_count (breakpoint_count
+ 1);
2817 b
->number
= breakpoint_count
;
2818 b
->type
= flags
>> 2;
2819 b
->disposition
= flags
& 3;
2821 /* FIXME: this won't work for duplicate basenames! */
2822 sprintf (buf
, "%s:%d", basename (Tcl_GetStringFromObj ( objv
[1], NULL
)), line
);
2823 b
->addr_string
= strsave (buf
);
2825 /* now send notification command back to GUI */
2827 Tcl_DStringInit (&cmd
);
2829 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2830 sprintf (buf
, "%d", b
->number
);
2831 Tcl_DStringAppendElement(&cmd
, buf
);
2832 sprintf (buf
, "0x%lx", (long)sal
.pc
);
2833 Tcl_DStringAppendElement (&cmd
, buf
);
2834 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[2], NULL
));
2835 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[1], NULL
));
2837 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2838 Tcl_DStringFree (&cmd
);
2842 /* This implements the tcl command gdb_get_breakpoint_info
2848 * A list with {file, function, line_number, address, type, enabled?,
2849 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
2853 gdb_get_breakpoint_info (clientData
, interp
, objc
, objv
)
2854 ClientData clientData
;
2857 Tcl_Obj
*CONST objv
[];
2859 struct symtab_and_line sal
;
2860 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
2861 "finish", "watchpoint", "hardware watchpoint",
2862 "read watchpoint", "access watchpoint",
2863 "longjmp", "longjmp resume", "step resume",
2864 "through sigtramp", "watchpoint scope",
2866 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
2867 struct command_line
*cmd
;
2869 struct breakpoint
*b
;
2870 extern struct breakpoint
*breakpoint_chain
;
2871 char *funcname
, *fname
, *filename
;
2876 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong number of args, should be \"breakpoint\"", -1);
2880 if ( Tcl_GetIntFromObj(NULL
, objv
[1], &bpnum
) != TCL_OK
)
2882 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2886 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2887 if (b
->number
== bpnum
)
2890 if (!b
|| b
->type
!= bp_breakpoint
)
2892 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Breakpoint #%d does not exist", -1);
2896 sal
= find_pc_line (b
->address
, 0);
2898 filename
= symtab_to_filename (sal
.symtab
);
2899 if (filename
== NULL
)
2902 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
2903 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2904 Tcl_NewStringObj (filename
, -1));
2906 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
2907 fname
= cplus_demangle (funcname
, 0);
2910 new_obj
= Tcl_NewStringObj (fname
, -1);
2914 new_obj
= Tcl_NewStringObj (funcname
, -1);
2916 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2918 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->line_number
));
2919 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%lx", b
->address
);
2920 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2921 Tcl_NewStringObj (bptypes
[b
->type
], -1));
2922 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewBooleanObj(b
->enable
== enabled
));
2923 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2924 Tcl_NewStringObj (bpdisp
[b
->disposition
], -1));
2925 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->ignore_count
));
2927 new_obj
= Tcl_NewObj();
2928 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
2929 Tcl_ListObjAppendElement (NULL
, new_obj
,
2930 Tcl_NewStringObj (cmd
->line
, -1));
2931 Tcl_ListObjAppendElement(NULL
, result_ptr
->obj_ptr
, new_obj
);
2933 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2934 Tcl_NewStringObj (b
->cond_string
, -1));
2936 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->thread
));
2937 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->hit_count
));
2943 /* This implements the tcl command gdb_get_breakpoint_list
2944 * It builds up a list of the current breakpoints.
2949 * A list of breakpoint numbers.
2953 gdb_get_breakpoint_list (clientData
, interp
, objc
, objv
)
2954 ClientData clientData
;
2957 Tcl_Obj
*CONST objv
[];
2959 struct breakpoint
*b
;
2960 extern struct breakpoint
*breakpoint_chain
;
2964 error ("wrong number of args, none are allowed");
2966 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2967 if (b
->type
== bp_breakpoint
)
2969 new_obj
= Tcl_NewIntObj (b
->number
);
2970 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2976 /* The functions in this section deal with stacks and backtraces. */
2978 /* This implements the tcl command gdb_stack.
2979 * It builds up a list of stack frames.
2982 * start - starting stack frame
2983 * count - number of frames to inspect
2985 * A list of function names
2989 gdb_stack (clientData
, interp
, objc
, objv
) ClientData clientData
;
2992 Tcl_Obj
*CONST objv
[];
2998 Tcl_WrongNumArgs (interp
, 1, objv
, "start count");
2999 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3003 if (Tcl_GetIntFromObj (NULL
, objv
[1], &start
))
3005 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3008 if (Tcl_GetIntFromObj (NULL
, objv
[2], &count
))
3010 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3014 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
3016 if (target_has_stack
)
3018 struct frame_info
*top
;
3019 struct frame_info
*fi
;
3021 /* Find the outermost frame */
3022 fi
= get_current_frame ();
3026 fi
= get_prev_frame (fi
);
3029 /* top now points to the top (outermost frame) of the
3030 stack, so point it to the requested start */
3032 top
= find_relative_frame (top
, &start
);
3034 /* If start != 0, then we have asked to start outputting
3035 frames beyond the innermost stack frame */
3039 while (fi
&& count
--)
3041 get_frame_name (interp
, result_ptr
->obj_ptr
, fi
);
3042 fi
= get_next_frame (fi
);
3050 /* A helper function for get_stack which adds information about
3051 * the stack frame FI to the caller's LIST.
3053 * This is stolen from print_frame_info in stack.c.
3056 get_frame_name (interp
, list
, fi
)
3059 struct frame_info
*fi
;
3061 struct symtab_and_line sal
;
3062 struct symbol
*func
= NULL
;
3063 register char *funname
= 0;
3064 enum language funlang
= language_unknown
;
3067 if (frame_in_dummy (fi
))
3069 objv
[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
3070 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3073 if (fi
->signal_handler_caller
)
3075 objv
[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
3076 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3081 find_pc_line (fi
->pc
,
3083 && !fi
->next
->signal_handler_caller
3084 && !frame_in_dummy (fi
->next
));
3086 func
= find_pc_function (fi
->pc
);
3089 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3091 && (SYMBOL_VALUE_ADDRESS (msymbol
)
3092 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
3095 funname
= SYMBOL_NAME (msymbol
);
3096 funlang
= SYMBOL_LANGUAGE (msymbol
);
3100 funname
= SYMBOL_NAME (func
);
3101 funlang
= SYMBOL_LANGUAGE (func
);
3106 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3107 if (msymbol
!= NULL
)
3109 funname
= SYMBOL_NAME (msymbol
);
3110 funlang
= SYMBOL_LANGUAGE (msymbol
);
3116 objv
[0] = Tcl_NewStringObj (funname
, -1);
3117 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3122 /* we have no convenient way to deal with this yet... */
3123 if (fi
->pc
!= sal
.pc
|| !sal
.symtab
)
3125 print_address_numeric (fi
->pc
, 1, gdb_stdout
);
3126 printf_filtered (" in ");
3128 printf_symbol_filtered (gdb_stdout
, funname
? funname
: "??", funlang
,
3131 objv
[0] = Tcl_NewStringObj (funname
!= NULL
? funname
: "??", -1);
3132 #ifdef PC_LOAD_SEGMENT
3133 /* If we couldn't print out function name but if can figure out what
3134 load segment this pc value is from, at least print out some info
3135 about its load segment. */
3138 Tcl_AppendStringsToObj (objv
[0], " from ", PC_LOAD_SEGMENT (fi
->pc
),
3145 char *lib
= PC_SOLIB (fi
->pc
);
3148 Tcl_AppendStringsToObj (objv
[0], " from ", lib
, (char *) NULL
);
3152 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3158 * This section contains a bunch of miscellaneous utility commands
3161 /* This implements the tcl command gdb_path_conv
3163 * On Windows, it canonicalizes the pathname,
3164 * On Unix, it is a no op.
3169 * The canonicalized path.
3173 gdb_path_conv (clientData
, interp
, objc
, objv
)
3174 ClientData clientData
;
3177 Tcl_Obj
*CONST objv
[];
3180 error ("wrong # args");
3184 char pathname
[256], *ptr
;
3186 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj(objv
[1], NULL
), pathname
);
3187 for (ptr
= pathname
; *ptr
; ptr
++)
3192 Tcl_SetStringObj (result_ptr
->obj_ptr
, pathname
, -1);
3195 Tcl_SetStringObj (result_ptr
->obj_ptr
, Tcl_GetStringFromObj (objv
[1], NULL
), -1);
3202 * This section has utility routines that are not Tcl commands.
3206 perror_with_name_wrapper (args
)
3209 perror_with_name (args
);
3213 /* The lookup_symtab() in symtab.c doesn't work correctly */
3214 /* It will not work will full pathnames and if multiple */
3215 /* source files have the same basename, it will return */
3216 /* the first one instead of the correct one. This version */
3217 /* also always makes sure symtab->fullname is set. */
3219 static struct symtab
*
3220 full_lookup_symtab(file
)
3224 struct objfile
*objfile
;
3225 char *bfile
, *fullname
;
3226 struct partial_symtab
*pt
;
3231 /* first try a direct lookup */
3232 st
= lookup_symtab (file
);
3236 symtab_to_filename(st
);
3240 /* if the direct approach failed, try */
3241 /* looking up the basename and checking */
3242 /* all matches with the fullname */
3243 bfile
= basename (file
);
3244 ALL_SYMTABS (objfile
, st
)
3246 if (!strcmp (bfile
, basename(st
->filename
)))
3249 fullname
= symtab_to_filename (st
);
3251 fullname
= st
->fullname
;
3253 if (!strcmp (file
, fullname
))
3258 /* still no luck? look at psymtabs */
3259 ALL_PSYMTABS (objfile
, pt
)
3261 if (!strcmp (bfile
, basename(pt
->filename
)))
3263 st
= PSYMTAB_TO_SYMTAB (pt
);
3266 fullname
= symtab_to_filename (st
);
3267 if (!strcmp (file
, fullname
))