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 /* gdb_context is used for debugging multiple threads or tasks */
312 Tcl_LinkVar (interp
, "gdb_context_id",
313 (char *) &gdb_context
,
314 TCL_LINK_INT
| TCL_LINK_READ_ONLY
);
316 Tcl_PkgProvide(interp
, "Gdbtk", GDBTK_VERSION
);
320 /* This routine acts as a top-level for all GDB code called by Tcl/Tk. It
321 handles cleanups, and uses catch_errors to trap calls to return_to_top_level
323 This is necessary in order to prevent a longjmp out of the bowels of Tk,
324 possibly leaving things in a bad state. Since this routine can be called
325 recursively, it needs to save and restore the contents of the result_ptr as
329 call_wrapper (clientData
, interp
, objc
, objv
)
330 ClientData clientData
;
333 Tcl_Obj
*CONST objv
[];
335 struct wrapped_call_args wrapped_args
;
336 gdbtk_result new_result
, *old_result_ptr
;
338 old_result_ptr
= result_ptr
;
339 result_ptr
= &new_result
;
340 result_ptr
->obj_ptr
= Tcl_NewObj();
341 result_ptr
->flags
= GDBTK_TO_RESULT
;
343 wrapped_args
.func
= (Tcl_ObjCmdProc
*) clientData
;
344 wrapped_args
.interp
= interp
;
345 wrapped_args
.objc
= objc
;
346 wrapped_args
.objv
= objv
;
347 wrapped_args
.val
= TCL_OK
;
349 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
352 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
354 /* Make sure the timer interrupts are turned off. */
358 gdb_flush (gdb_stderr
); /* Flush error output */
359 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
361 /* If we errored out here, and the results were going to the
362 console, then gdbtk_fputs will have gathered the result into the
363 result_ptr. We also need to echo them out to the console here */
365 gdb_flush (gdb_stderr
); /* Flush error output */
366 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
368 /* In case of an error, we may need to force the GUI into idle
369 mode because gdbtk_call_command may have bombed out while in
370 the command routine. */
373 Tcl_Eval (interp
, "gdbtk_tcl_idle");
377 /* do not suppress any errors -- a remote target could have errored */
378 load_in_progress
= 0;
381 * Now copy the result over to the true Tcl result. If GDBTK_TO_RESULT flag
382 * bit is set , this just copies a null object over to the Tcl result, which is
383 * fine because we should reset the result in this case anyway.
385 if (result_ptr
->flags
& GDBTK_IN_TCL_RESULT
)
387 Tcl_DecrRefCount(result_ptr
->obj_ptr
);
391 Tcl_SetObjResult (interp
, result_ptr
->obj_ptr
);
394 result_ptr
= old_result_ptr
;
400 return wrapped_args
.val
;
404 * This is the wrapper that is passed to catch_errors.
408 wrapped_call (opaque_args
)
411 struct wrapped_call_args
*args
= (struct wrapped_call_args
*) opaque_args
;
412 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->objc
, args
->objv
);
416 /* This is a convenience function to sprintf something(s) into a
417 * new element in a Tcl list object.
421 #ifdef ANSI_PROTOTYPES
422 sprintf_append_element_to_obj (Tcl_Obj
*objp
, char *format
, ...)
424 sprintf_append_element_to_obj (va_alist
)
431 #ifdef ANSI_PROTOTYPES
432 va_start (args
, format
);
438 dsp
= va_arg (args
, Tcl_Obj
*);
439 format
= va_arg (args
, char *);
442 vsprintf (buf
, format
, args
);
444 Tcl_ListObjAppendElement (NULL
, objp
, Tcl_NewStringObj (buf
, -1));
448 * This section contains the commands that control execution.
451 /* This implements the tcl command gdb_clear_file.
453 * Prepare to accept a new executable file. This is called when we
454 * want to clear away everything we know about the old file, without
455 * asking the user. The Tcl code will have already asked the user if
456 * necessary. After this is called, we should be able to run the
457 * `file' command without getting any questions.
466 gdb_clear_file (clientData
, interp
, objc
, objv
)
467 ClientData clientData
;
470 Tcl_Obj
*CONST objv
[];
473 Tcl_SetStringObj (result_ptr
->obj_ptr
,
474 "Wrong number of args, none are allowed.", -1);
476 if (inferior_pid
!= 0 && target_has_execution
)
479 target_detach (NULL
, 0);
484 if (target_has_execution
)
487 symbol_file_command (NULL
, 0);
489 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
490 clear it here. FIXME: This seems like an abstraction violation
497 /* This implements the tcl command gdb_confirm_quit
498 * Ask the user to confirm an exit request.
503 * A boolean, 1 if the user answered yes, 0 if no.
507 gdb_confirm_quit (clientData
, interp
, objc
, objv
)
508 ClientData clientData
;
511 Tcl_Obj
*CONST objv
[];
517 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
521 ret
= quit_confirm ();
522 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, ret
);
526 /* This implements the tcl command gdb_force_quit
527 * Quit without asking for confirmation.
536 gdb_force_quit (clientData
, interp
, objc
, objv
)
537 ClientData clientData
;
540 Tcl_Obj
*CONST objv
[];
544 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
548 quit_force ((char *) NULL
, 1);
552 /* This implements the tcl command gdb_stop
553 * It stops the target in a continuable fashion.
562 gdb_stop (clientData
, interp
, objc
, objv
)
563 ClientData clientData
;
566 Tcl_Obj
*CONST objv
[];
573 quit_flag
= 1; /* hope something sees this */
580 * This section contains Tcl commands that are wrappers for invoking
581 * the GDB command interpreter.
585 /* This implements the tcl command `gdb_eval'.
586 * It uses the gdb evaluator to return the value of
587 * an expression in the current language
590 * expression - the expression to evaluate.
592 * The result of the evaluation.
596 gdb_eval (clientData
, interp
, objc
, objv
)
597 ClientData clientData
;
600 Tcl_Obj
*CONST objv
[];
602 struct expression
*expr
;
603 struct cleanup
*old_chain
=NULL
;
608 Tcl_SetStringObj (result_ptr
->obj_ptr
,
609 "wrong # args, should be \"gdb_eval expression\"", -1);
613 expr
= parse_expression (Tcl_GetStringFromObj (objv
[1], NULL
));
615 old_chain
= make_cleanup (free_current_contents
, &expr
);
617 val
= evaluate_expression (expr
);
620 * Print the result of the expression evaluation. This will go to
621 * eventually go to gdbtk_fputs, and from there be collected into
625 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
626 gdb_stdout
, 0, 0, 0, 0);
628 do_cleanups (old_chain
);
633 /* This implements the tcl command "gdb_cmd".
635 * It sends its argument to the GDB command scanner for execution.
636 * This command will never cause the update, idle and busy hooks to be called
640 * command - The GDB command to execute
642 * The output from the gdb command (except for the "load" & "while"
643 * which dump their output to the console.
647 gdb_cmd (clientData
, interp
, objc
, objv
)
648 ClientData clientData
;
651 Tcl_Obj
*CONST objv
[];
656 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
660 if (running_now
|| load_in_progress
)
665 /* for the load instruction (and possibly others later) we
666 set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
667 will not buffer all the data until the command is finished. */
669 if ((strncmp ("load ", Tcl_GetStringFromObj (objv
[1], NULL
), 5) == 0)
670 || (strncmp ("while ", Tcl_GetStringFromObj (objv
[1], NULL
), 6) == 0))
672 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
673 load_in_progress
= 1;
674 gdbtk_start_timer ();
677 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
679 if (load_in_progress
)
682 load_in_progress
= 0;
683 result_ptr
->flags
|= GDBTK_TO_RESULT
;
686 bpstat_do_actions (&stop_bpstat
);
692 * This implements the tcl command "gdb_immediate"
694 * It does exactly the same thing as gdb_cmd, except NONE of its outut
695 * is buffered. This will also ALWAYS cause the busy, update, and idle hooks to
696 * be called, contrasted with gdb_cmd, which NEVER calls them.
697 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
698 * to the console window.
701 * command - The GDB command to execute
707 gdb_immediate_command (clientData
, interp
, objc
, objv
)
708 ClientData clientData
;
711 Tcl_Obj
*CONST objv
[];
716 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
720 if (running_now
|| load_in_progress
)
725 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
727 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
729 bpstat_do_actions (&stop_bpstat
);
731 result_ptr
->flags
|= GDBTK_TO_RESULT
;
736 /* This implements the tcl command "gdb_prompt"
738 * It returns the gdb interpreter's prompt.
747 gdb_prompt_command (clientData
, interp
, objc
, objv
)
748 ClientData clientData
;
751 Tcl_Obj
*CONST objv
[];
753 Tcl_SetStringObj (result_ptr
->obj_ptr
, get_prompt (), -1);
759 * This section contains general informational commands.
762 /* This implements the tcl command "gdb_target_has_execution"
764 * Tells whether the target is executing.
769 * A boolean indicating whether the target is executing.
773 gdb_target_has_execution_command (clientData
, interp
, objc
, objv
)
774 ClientData clientData
;
777 Tcl_Obj
*CONST objv
[];
781 if (target_has_execution
&& inferior_pid
!= 0)
784 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, result
);
788 /* This implements the tcl command "gdb_load_info"
790 * It returns information about the file about to be downloaded.
793 * filename: The file to open & get the info on.
795 * A list consisting of the name and size of each section.
799 gdb_load_info (clientData
, interp
, objc
, objv
)
800 ClientData clientData
;
803 Tcl_Obj
*CONST objv
[];
806 struct cleanup
*old_cleanups
;
810 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
812 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
813 if (loadfile_bfd
== NULL
)
815 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Open failed", -1);
818 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
820 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
822 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Bad Object File", -1);
826 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
828 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
830 if (s
->flags
& SEC_LOAD
)
832 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
835 ob
[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd
, s
), -1);
836 ob
[1] = Tcl_NewLongObj ((long) size
);
837 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewListObj (2, ob
));
842 do_cleanups (old_cleanups
);
848 * This and gdb_get_locals just call gdb_get_vars_command with the right
849 * value of clientData. We can't use the client data in the definition
850 * of the command, because the call wrapper uses this instead...
854 gdb_get_locals_command (clientData
, interp
, objc
, objv
)
855 ClientData clientData
;
858 Tcl_Obj
*CONST objv
[];
861 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
866 gdb_get_args_command (clientData
, interp
, objc
, objv
)
867 ClientData clientData
;
870 Tcl_Obj
*CONST objv
[];
873 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
877 /* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
879 * This function sets the Tcl interpreter's result to a list of variable names
880 * depending on clientData. If clientData is one, the result is a list of
881 * arguments; zero returns a list of locals -- all relative to the block
882 * specified as an argument to the command. Valid commands include
883 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
887 * block - the address within which to specify the locals or args.
889 * A list of the locals or args
893 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
894 ClientData clientData
;
897 Tcl_Obj
*CONST objv
[];
899 struct symtabs_and_lines sals
;
902 char **canonical
, *args
;
903 int i
, nsyms
, arguments
;
907 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
,
908 "wrong # of args: should be \"",
909 Tcl_GetStringFromObj (objv
[0], NULL
),
910 " function:line|function|line|*addr\"", NULL
);
914 arguments
= (int) clientData
;
915 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
916 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
919 Tcl_SetStringObj (result_ptr
->obj_ptr
,
920 "error decoding line", -1);
924 /* Initialize the result pointer to an empty list. */
926 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
928 /* Resolve all line numbers to PC's */
929 for (i
= 0; i
< sals
.nelts
; i
++)
930 resolve_sal_pc (&sals
.sals
[i
]);
932 block
= block_for_pc (sals
.sals
[0].pc
);
935 nsyms
= BLOCK_NSYMS (block
);
936 for (i
= 0; i
< nsyms
; i
++)
938 sym
= BLOCK_SYM (block
, i
);
939 switch (SYMBOL_CLASS (sym
)) {
941 case LOC_UNDEF
: /* catches errors */
942 case LOC_CONST
: /* constant */
943 case LOC_TYPEDEF
: /* local typedef */
944 case LOC_LABEL
: /* local label */
945 case LOC_BLOCK
: /* local function */
946 case LOC_CONST_BYTES
: /* loc. byte seq. */
947 case LOC_UNRESOLVED
: /* unresolved static */
948 case LOC_OPTIMIZED_OUT
: /* optimized out */
950 case LOC_ARG
: /* argument */
951 case LOC_REF_ARG
: /* reference arg */
952 case LOC_REGPARM
: /* register arg */
953 case LOC_REGPARM_ADDR
: /* indirect register arg */
954 case LOC_LOCAL_ARG
: /* stack arg */
955 case LOC_BASEREG_ARG
: /* basereg arg */
957 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
958 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
960 case LOC_LOCAL
: /* stack local */
961 case LOC_BASEREG
: /* basereg local */
962 case LOC_STATIC
: /* static */
963 case LOC_REGISTER
: /* register */
965 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
966 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
970 if (BLOCK_FUNCTION (block
))
973 block
= BLOCK_SUPERBLOCK (block
);
979 /* This implements the tcl command "gdb_get_line"
981 * It returns the linenumber for a given linespec. It will take any spec
982 * that can be passed to decode_line_1
985 * linespec - the line specification
987 * The line number for that spec.
990 gdb_get_line_command (clientData
, interp
, objc
, objv
)
991 ClientData clientData
;
994 Tcl_Obj
*CONST objv
[];
996 struct symtabs_and_lines sals
;
997 char *args
, **canonical
;
1001 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1002 Tcl_GetStringFromObj (objv
[0], NULL
),
1003 " linespec\"", NULL
);
1007 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1008 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1009 if (sals
.nelts
== 1)
1011 Tcl_SetIntObj (result_ptr
->obj_ptr
, sals
.sals
[0].line
);
1015 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1020 /* This implements the tcl command "gdb_get_file"
1022 * It returns the file containing a given line spec.
1025 * linespec - The linespec to look up
1027 * The file containing it.
1031 gdb_get_file_command (clientData
, interp
, objc
, objv
)
1032 ClientData clientData
;
1035 Tcl_Obj
*CONST objv
[];
1037 struct symtabs_and_lines sals
;
1038 char *args
, **canonical
;
1042 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1043 Tcl_GetStringFromObj (objv
[0], NULL
),
1044 " linespec\"", NULL
);
1048 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1049 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1050 if (sals
.nelts
== 1)
1052 Tcl_SetStringObj (result_ptr
->obj_ptr
, sals
.sals
[0].symtab
->filename
, -1);
1056 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1060 /* This implements the tcl command "gdb_get_function"
1062 * It finds the function containing the given line spec.
1065 * linespec - The line specification
1067 * The function that contains it, or "N/A" if it is not in a function.
1070 gdb_get_function_command (clientData
, interp
, objc
, objv
)
1071 ClientData clientData
;
1074 Tcl_Obj
*CONST objv
[];
1077 struct symtabs_and_lines sals
;
1078 char *args
, **canonical
;
1082 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1083 Tcl_GetStringFromObj (objv
[0], NULL
),
1084 " linespec\"", NULL
);
1088 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1089 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1090 if (sals
.nelts
== 1)
1092 resolve_sal_pc (&sals
.sals
[0]);
1093 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
1094 if (function
!= NULL
)
1096 Tcl_SetStringObj (result_ptr
->obj_ptr
, function
, -1);
1101 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1105 /* This implements the tcl command "gdb_find_file"
1107 * It searches the symbol tables to get the full pathname to a file.
1110 * filename: the file name to search for.
1112 * The full path to the file, or an empty string if the file is not
1117 gdb_find_file_command (clientData
, interp
, objc
, objv
)
1118 ClientData clientData
;
1121 Tcl_Obj
*CONST objv
[];
1123 char *filename
= NULL
;
1128 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
1132 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1134 filename
= st
->fullname
;
1136 if (filename
== NULL
)
1137 Tcl_SetStringObj (result_ptr
->obj_ptr
, "", 0);
1139 Tcl_SetStringObj (result_ptr
->obj_ptr
, filename
, -1);
1144 /* This implements the tcl command "gdb_listfiles"
1146 * This lists all the files in the current executible.
1148 * Note that this currently pulls in all sorts of filenames
1149 * that aren't really part of the executable. It would be
1150 * best if we could check each file to see if it actually
1151 * contains executable lines of code, but we can't do that
1155 * ?pathname? - If provided, only files which match pathname
1156 * (up to strlen(pathname)) are included. THIS DOES NOT
1157 * CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1158 * THE FULL PATHNAME!!!
1161 * A list of all matching files.
1164 gdb_listfiles (clientData
, interp
, objc
, objv
)
1165 ClientData clientData
;
1168 Tcl_Obj
*CONST objv
[];
1170 struct objfile
*objfile
;
1171 struct partial_symtab
*psymtab
;
1172 struct symtab
*symtab
;
1173 char *lastfile
, *pathname
=NULL
, **files
;
1175 int i
, numfiles
= 0, len
= 0;
1178 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1182 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1186 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1188 ALL_PSYMTABS (objfile
, psymtab
)
1190 if (numfiles
== files_size
)
1192 files_size
= files_size
* 2;
1193 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1195 if (psymtab
->filename
)
1197 if (!len
|| !strncmp(pathname
, psymtab
->filename
,len
)
1198 || !strcmp(psymtab
->filename
, basename(psymtab
->filename
)))
1200 files
[numfiles
++] = basename(psymtab
->filename
);
1205 ALL_SYMTABS (objfile
, symtab
)
1207 if (numfiles
== files_size
)
1209 files_size
= files_size
* 2;
1210 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1212 if (symtab
->filename
&& symtab
->linetable
&& symtab
->linetable
->nitems
)
1214 if (!len
|| !strncmp(pathname
, symtab
->filename
,len
)
1215 || !strcmp(symtab
->filename
, basename(symtab
->filename
)))
1217 files
[numfiles
++] = basename(symtab
->filename
);
1222 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1226 /* Discard the old result pointer, in case it has accumulated anything
1227 and set it to a new list object */
1229 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1231 for (i
= 0; i
< numfiles
; i
++)
1233 if (strcmp(files
[i
],lastfile
))
1234 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj(files
[i
], -1));
1235 lastfile
= files
[i
];
1243 comp_files (file1
, file2
)
1244 const void *file1
, *file2
;
1246 return strcmp(* (char **) file1
, * (char **) file2
);
1250 /* This implements the tcl command "gdb_search"
1254 * option - One of "functions", "variables" or "types"
1255 * regexp - The regular expression to look for.
1264 gdb_search (clientData
, interp
, objc
, objv
)
1265 ClientData clientData
;
1268 Tcl_Obj
*CONST objv
[];
1270 struct symbol_search
*ss
= NULL
;
1271 struct symbol_search
*p
;
1272 struct cleanup
*old_chain
= NULL
;
1273 Tcl_Obj
*CONST
*switch_objv
;
1274 int index
, switch_objc
, i
;
1275 namespace_enum space
= 0;
1277 int static_only
, nfiles
;
1278 Tcl_Obj
**file_list
;
1280 static char *search_options
[] = { "functions", "variables", "types", (char *) NULL
};
1281 static char *switches
[] = { "-files", "-static", (char *) NULL
};
1282 enum search_opts
{ SEARCH_FUNCTIONS
, SEARCH_VARIABLES
, SEARCH_TYPES
};
1283 enum switches_opts
{ SWITCH_FILES
, SWITCH_STATIC_ONLY
};
1287 Tcl_WrongNumArgs (interp
, 1, objv
, "option regexp ?arg ...?");
1288 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1292 if (Tcl_GetIndexFromObj (interp
, objv
[1], search_options
, "option", 0,
1295 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1299 /* Unfortunately, we cannot teach search_symbols to search on
1300 multiple regexps, so we have to do a two-tier search for
1301 any searches which choose to narrow the playing field. */
1302 switch ((enum search_opts
) index
)
1304 case SEARCH_FUNCTIONS
:
1305 space
= FUNCTIONS_NAMESPACE
; break;
1306 case SEARCH_VARIABLES
:
1307 space
= VARIABLES_NAMESPACE
; break;
1309 space
= TYPES_NAMESPACE
; break;
1312 regexp
= Tcl_GetStringFromObj (objv
[2], NULL
);
1313 /* Process any switches that refine the search */
1314 switch_objc
= objc
- 3;
1315 switch_objv
= objv
+ 3;
1319 files
= (char **) NULL
;
1320 while (switch_objc
> 0)
1322 if (Tcl_GetIndexFromObj (interp
, switch_objv
[0], switches
,
1323 "option", 0, &index
) != TCL_OK
)
1325 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1329 switch ((enum switches_opts
) index
)
1334 if (switch_objc
< 2)
1336 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList -static 1|0]");
1337 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1340 result
= Tcl_ListObjGetElements (interp
, switch_objv
[1], &nfiles
, &file_list
);
1341 if (result
!= TCL_OK
)
1344 files
= (char **) xmalloc (nfiles
* sizeof (char *));
1345 for (i
= 0; i
< nfiles
; i
++)
1346 files
[i
] = Tcl_GetStringFromObj (file_list
[i
], NULL
);
1351 case SWITCH_STATIC_ONLY
:
1352 if (switch_objc
< 2)
1354 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList] [-static 1|0]");
1355 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1358 if ( Tcl_GetBooleanFromObj (interp
, switch_objv
[1], &static_only
) !=
1360 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1370 search_symbols (regexp
, space
, nfiles
, files
, &ss
);
1372 old_chain
= make_cleanup (free_search_symbols
, ss
);
1374 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1376 for (p
= ss
; p
!= NULL
; p
= p
->next
)
1380 if (static_only
&& p
->block
!= STATIC_BLOCK
)
1383 elem
= Tcl_NewListObj (0, NULL
);
1385 if (p
->msymbol
== NULL
)
1386 Tcl_ListObjAppendElement (interp
, elem
,
1387 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->symbol
), -1));
1389 Tcl_ListObjAppendElement (interp
, elem
,
1390 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->msymbol
), -1));
1392 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, elem
);
1396 do_cleanups (old_chain
);
1401 /* This implements the tcl command gdb_listfuncs
1403 * It lists all the functions defined in a given file
1406 * file - the file to look in
1408 * A list of two element lists, the first element is
1409 * the symbol name, and the second is a boolean indicating
1410 * whether the symbol is demangled (1 for yes).
1414 gdb_listfuncs (clientData
, interp
, objc
, objv
)
1415 ClientData clientData
;
1418 Tcl_Obj
*CONST objv
[];
1420 struct symtab
*symtab
;
1421 struct blockvector
*bv
;
1425 Tcl_Obj
*funcVals
[2];
1429 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1432 symtab
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1435 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No such file", -1);
1439 if (mangled
== NULL
)
1441 mangled
= Tcl_NewBooleanObj(1);
1442 not_mangled
= Tcl_NewBooleanObj(0);
1443 Tcl_IncrRefCount(mangled
);
1444 Tcl_IncrRefCount(not_mangled
);
1447 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1449 bv
= BLOCKVECTOR (symtab
);
1450 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1452 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1453 /* Skip the sort if this block is always sorted. */
1454 if (!BLOCK_SHOULD_SORT (b
))
1455 sort_block_syms (b
);
1456 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1458 sym
= BLOCK_SYM (b
, j
);
1459 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1462 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1465 /* strip out "global constructors" and "global destructors" */
1466 /* because we aren't interested in them. */
1467 if (strncmp (name
, "global ", 7))
1469 funcVals
[0] = Tcl_NewStringObj(name
, -1);
1470 funcVals
[1] = mangled
;
1478 funcVals
[0] = Tcl_NewStringObj(SYMBOL_NAME(sym
), -1);
1479 funcVals
[1] = not_mangled
;
1481 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1482 Tcl_NewListObj (2, funcVals
));
1491 * This section contains all the commands that act on the registers:
1494 /* This is a sort of mapcar function for operations on registers */
1497 map_arg_registers (objc
, objv
, func
, argp
)
1499 Tcl_Obj
*CONST objv
[];
1500 void (*func
) PARAMS ((int regnum
, void *argp
));
1505 /* Note that the test for a valid register must include checking the
1506 reg_names array because NUM_REGS may be allocated for the union of the
1507 register sets within a family of related processors. In this case, the
1508 trailing entries of reg_names will change depending upon the particular
1509 processor being debugged. */
1511 if (objc
== 0) /* No args, just do all the regs */
1515 && reg_names
[regnum
] != NULL
1516 && *reg_names
[regnum
] != '\000';
1518 func (regnum
, argp
);
1523 /* Else, list of register #s, just do listed regs */
1524 for (; objc
> 0; objc
--, objv
++)
1526 if (Tcl_GetIntFromObj (NULL
, *objv
, ®num
) != TCL_OK
)
1528 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1533 && regnum
< NUM_REGS
1534 && reg_names
[regnum
] != NULL
1535 && *reg_names
[regnum
] != '\000')
1536 func (regnum
, argp
);
1539 Tcl_SetStringObj (result_ptr
->obj_ptr
, "bad register number", -1);
1547 /* This implements the TCL command `gdb_regnames', which returns a list of
1548 all of the register names. */
1551 gdb_regnames (clientData
, interp
, objc
, objv
)
1552 ClientData clientData
;
1555 Tcl_Obj
*CONST objv
[];
1560 return map_arg_registers (objc
, objv
, get_register_name
, NULL
);
1564 get_register_name (regnum
, argp
)
1566 void *argp
; /* Ignored */
1568 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1569 Tcl_NewStringObj (reg_names
[regnum
], -1));
1572 /* This implements the tcl command gdb_fetch_registers
1573 * Pass it a list of register names, and it will
1574 * return their values as a list.
1577 * format: The format string for printing the values
1578 * args: the registers to look for
1580 * A list of their values.
1584 gdb_fetch_registers (clientData
, interp
, objc
, objv
)
1585 ClientData clientData
;
1588 Tcl_Obj
*CONST objv
[];
1594 Tcl_SetStringObj (result_ptr
->obj_ptr
,
1595 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
1599 format
= *(Tcl_GetStringFromObj(objv
[0], NULL
));
1603 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Output the results as a list */
1604 result
= map_arg_registers (objc
, objv
, get_register
, (void *) format
);
1605 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
1611 get_register (regnum
, fp
)
1615 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1616 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
1617 int format
= (int)fp
;
1622 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1624 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1625 Tcl_NewStringObj ("Optimized out", -1));
1629 /* Convert raw data to virtual format if necessary. */
1631 if (REGISTER_CONVERTIBLE (regnum
))
1633 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
1634 raw_buffer
, virtual_buffer
);
1637 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1642 printf_filtered ("0x");
1643 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1645 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1646 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1647 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
1651 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
1652 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1656 /* This implements the tcl command get_pc_reg
1657 * It returns the value of the PC register
1662 * The value of the pc register.
1666 get_pc_register (clientData
, interp
, objc
, objv
)
1667 ClientData clientData
;
1670 Tcl_Obj
*CONST objv
[];
1674 sprintf (buff
, "0x%llx",(long long) read_register (PC_REGNUM
));
1675 Tcl_SetStringObj(result_ptr
->obj_ptr
, buff
, -1);
1679 /* This implements the tcl command "gdb_changed_register_list"
1680 * It takes a list of registers, and returns a list of
1681 * the registers on that list that have changed since the last
1682 * time the proc was called.
1685 * A list of registers.
1687 * A list of changed registers.
1691 gdb_changed_register_list (clientData
, interp
, objc
, objv
)
1692 ClientData clientData
;
1695 Tcl_Obj
*CONST objv
[];
1700 return map_arg_registers (objc
, objv
, register_changed_p
, NULL
);
1704 register_changed_p (regnum
, argp
)
1706 void *argp
; /* Ignored */
1708 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1710 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1713 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1714 REGISTER_RAW_SIZE (regnum
)) == 0)
1717 /* Found a changed register. Save new value and return its number. */
1719 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1720 REGISTER_RAW_SIZE (regnum
));
1722 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(regnum
));
1726 * This section contains the commands that deal with tracepoints:
1729 /* return a list of all tracepoint numbers in interpreter */
1731 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
1732 ClientData clientData
;
1735 Tcl_Obj
*CONST objv
[];
1737 struct tracepoint
*tp
;
1739 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1741 ALL_TRACEPOINTS (tp
)
1742 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->number
));
1747 /* returns -1 if not found, tracepoint # if found */
1749 tracepoint_exists (char * args
)
1751 struct tracepoint
*tp
;
1753 struct symtabs_and_lines sals
;
1757 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1758 if (sals
.nelts
== 1)
1760 resolve_sal_pc (&sals
.sals
[0]);
1761 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
1762 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
1765 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
1766 strcat (file
, sals
.sals
[0].symtab
->filename
);
1768 ALL_TRACEPOINTS (tp
)
1770 if (tp
->address
== sals
.sals
[0].pc
)
1771 result
= tp
->number
;
1773 /* Why is this here? This messes up assembly traces */
1774 else if (tp
->source_file
!= NULL
1775 && strcmp (tp
->source_file
, file
) == 0
1776 && sals
.sals
[0].line
== tp
->line_number
)
1777 result
= tp
->number
;
1788 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
1789 ClientData clientData
;
1792 Tcl_Obj
*CONST objv
[];
1798 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1799 Tcl_GetStringFromObj (objv
[0], NULL
),
1800 " function:line|function|line|*addr\"", NULL
);
1804 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1806 Tcl_SetIntObj (result_ptr
->obj_ptr
, tracepoint_exists (args
));
1811 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
1812 ClientData clientData
;
1815 Tcl_Obj
*CONST objv
[];
1817 struct symtab_and_line sal
;
1819 struct tracepoint
*tp
;
1820 struct action_line
*al
;
1821 Tcl_Obj
*action_list
;
1822 char *filename
, *funcname
;
1827 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1831 if (Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
) != TCL_OK
)
1833 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1837 ALL_TRACEPOINTS (tp
)
1838 if (tp
->number
== tpnum
)
1843 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Tracepoint #%d does not exist", -1);
1847 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1848 sal
= find_pc_line (tp
->address
, 0);
1849 filename
= symtab_to_filename (sal
.symtab
);
1850 if (filename
== NULL
)
1852 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1853 Tcl_NewStringObj (filename
, -1));
1854 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
1855 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (funcname
, -1));
1856 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (sal
.line
));
1857 sprintf (tmp
, "0x%lx", tp
->address
);
1858 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (tmp
, -1));
1859 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->enabled
));
1860 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->pass_count
));
1861 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->step_count
));
1862 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->thread
));
1863 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->hit_count
));
1865 /* Append a list of actions */
1866 action_list
= Tcl_NewObj ();
1867 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
1869 Tcl_ListObjAppendElement (interp
, action_list
,
1870 Tcl_NewStringObj (al
->action
, -1));
1872 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, action_list
);
1879 gdb_trace_status (clientData
, interp
, objc
, objv
)
1880 ClientData clientData
;
1883 Tcl_Obj
*CONST objv
[];
1887 if (trace_running_p
)
1890 Tcl_SetIntObj (result_ptr
->obj_ptr
, result
);
1897 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
1898 ClientData clientData
;
1901 Tcl_Obj
*CONST objv
[];
1905 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1906 Tcl_GetStringFromObj (objv
[0], NULL
),
1907 " linespec\"", NULL
);
1911 Tcl_SetIntObj (result_ptr
->obj_ptr
, get_traceframe_number ());
1916 /* This implements the tcl command gdb_actions
1917 * It sets actions for a given tracepoint.
1920 * number: the tracepoint in question
1921 * actions: the actions to add to this tracepoint
1927 gdb_actions_command (clientData
, interp
, objc
, objv
)
1928 ClientData clientData
;
1931 Tcl_Obj
*CONST objv
[];
1933 struct tracepoint
*tp
;
1935 int nactions
, i
, len
;
1936 char *number
, *args
, *action
;
1938 struct action_line
*next
= NULL
, *temp
;
1939 enum actionline_type linetype
;
1943 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # args: should be: \"",
1944 Tcl_GetStringFromObj (objv
[0], NULL
),
1945 " number actions\"", NULL
);
1949 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
1950 tp
= get_tracepoint_by_number (&args
);
1953 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "Tracepoint \"", number
, "\" does not exist", NULL
);
1957 /* Free any existing actions */
1958 if (tp
->actions
!= NULL
)
1963 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
1965 /* Add the actions to the tracepoint */
1966 for (i
= 0; i
< nactions
; i
++)
1968 temp
= xmalloc (sizeof (struct action_line
));
1970 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
1971 temp
->action
= savestring (action
, len
);
1973 linetype
= validate_actionline (&(temp
->action
), tp
);
1975 if (linetype
== BADLINE
)
1997 * This section has commands that handle source disassembly.
2000 /* This implements the tcl command gdb_disassemble
2003 * source_with_assm - must be "source" or "nosource"
2004 * low_address - the address from which to start disassembly
2005 * ?hi_address? - the address to which to disassemble, defaults
2006 * to the end of the function containing low_address.
2008 * The disassembled code is passed to fputs_unfiltered, so it
2009 * either goes to the console if result_ptr->obj_ptr is NULL or to
2014 gdb_disassemble (clientData
, interp
, objc
, objv
)
2015 ClientData clientData
;
2018 Tcl_Obj
*CONST objv
[];
2020 CORE_ADDR pc
, low
, high
;
2021 int mixed_source_and_assembly
;
2022 static disassemble_info di
;
2023 static int di_initialized
;
2026 if (objc
!= 3 && objc
!= 4)
2027 error ("wrong # args");
2029 if (! di_initialized
)
2031 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
2032 (fprintf_ftype
) fprintf_unfiltered
);
2033 di
.flavour
= bfd_target_unknown_flavour
;
2034 di
.memory_error_func
= dis_asm_memory_error
;
2035 di
.print_address_func
= dis_asm_print_address
;
2039 di
.mach
= tm_print_insn_info
.mach
;
2040 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
2041 di
.endian
= BFD_ENDIAN_BIG
;
2043 di
.endian
= BFD_ENDIAN_LITTLE
;
2045 arg_ptr
= Tcl_GetStringFromObj (objv
[1], NULL
);
2046 if (*arg_ptr
== 's' && strcmp (arg_ptr
, "source") == 0)
2047 mixed_source_and_assembly
= 1;
2048 else if (*arg_ptr
== 'n' && strcmp (arg_ptr
, "nosource") == 0)
2049 mixed_source_and_assembly
= 0;
2051 error ("First arg must be 'source' or 'nosource'");
2053 low
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[2], NULL
));
2057 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
2058 error ("No function contains specified address");
2061 high
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[3], NULL
));
2063 /* If disassemble_from_exec == -1, then we use the following heuristic to
2064 determine whether or not to do disassembly from target memory or from the
2067 If we're debugging a local process, read target memory, instead of the
2068 exec file. This makes disassembly of functions in shared libs work
2071 Else, we're debugging a remote process, and should disassemble from the
2072 exec file for speed. However, this is no good if the target modifies its
2073 code (for relocation, or whatever).
2076 if (disassemble_from_exec
== -1)
2078 if (strcmp (target_shortname
, "child") == 0
2079 || strcmp (target_shortname
, "procfs") == 0
2080 || strcmp (target_shortname
, "vxprocess") == 0)
2081 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
2083 disassemble_from_exec
= 1; /* It's remote, read the exec file */
2086 if (disassemble_from_exec
)
2087 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
2089 di
.read_memory_func
= dis_asm_read_memory
;
2091 /* If just doing straight assembly, all we need to do is disassemble
2092 everything between low and high. If doing mixed source/assembly, we've
2093 got a totally different path to follow. */
2095 if (mixed_source_and_assembly
)
2096 { /* Come here for mixed source/assembly */
2097 /* The idea here is to present a source-O-centric view of a function to
2098 the user. This means that things are presented in source order, with
2099 (possibly) out of order assembly immediately following. */
2100 struct symtab
*symtab
;
2101 struct linetable_entry
*le
;
2104 struct my_line_entry
*mle
;
2105 struct symtab_and_line sal
;
2110 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
2115 /* First, convert the linetable to a bunch of my_line_entry's. */
2117 le
= symtab
->linetable
->item
;
2118 nlines
= symtab
->linetable
->nitems
;
2123 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
2127 /* Copy linetable entries for this function into our data structure, creating
2128 end_pc's and setting out_of_order as appropriate. */
2130 /* First, skip all the preceding functions. */
2132 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
2134 /* Now, copy all entries before the end of this function. */
2137 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
2139 if (le
[i
].line
== le
[i
+ 1].line
2140 && le
[i
].pc
== le
[i
+ 1].pc
)
2141 continue; /* Ignore duplicates */
2143 mle
[newlines
].line
= le
[i
].line
;
2144 if (le
[i
].line
> le
[i
+ 1].line
)
2146 mle
[newlines
].start_pc
= le
[i
].pc
;
2147 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
2151 /* If we're on the last line, and it's part of the function, then we need to
2152 get the end pc in a special way. */
2157 mle
[newlines
].line
= le
[i
].line
;
2158 mle
[newlines
].start_pc
= le
[i
].pc
;
2159 sal
= find_pc_line (le
[i
].pc
, 0);
2160 mle
[newlines
].end_pc
= sal
.end
;
2164 /* Now, sort mle by line #s (and, then by addresses within lines). */
2167 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
2169 /* Now, for each line entry, emit the specified lines (unless they have been
2170 emitted before), followed by the assembly code for that line. */
2172 next_line
= 0; /* Force out first line */
2173 for (i
= 0; i
< newlines
; i
++)
2175 /* Print out everything from next_line to the current line. */
2177 if (mle
[i
].line
>= next_line
)
2180 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
2182 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
2184 next_line
= mle
[i
].line
+ 1;
2187 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
2190 fputs_unfiltered (" ", gdb_stdout
);
2191 print_address (pc
, gdb_stdout
);
2192 fputs_unfiltered (":\t ", gdb_stdout
);
2193 pc
+= (*tm_print_insn
) (pc
, &di
);
2194 fputs_unfiltered ("\n", gdb_stdout
);
2201 for (pc
= low
; pc
< high
; )
2204 fputs_unfiltered (" ", gdb_stdout
);
2205 print_address (pc
, gdb_stdout
);
2206 fputs_unfiltered (":\t ", gdb_stdout
);
2207 pc
+= (*tm_print_insn
) (pc
, &di
);
2208 fputs_unfiltered ("\n", gdb_stdout
);
2212 gdb_flush (gdb_stdout
);
2217 /* This is the memory_read_func for gdb_disassemble when we are
2218 disassembling from the exec file. */
2221 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
2225 disassemble_info
*info
;
2227 extern struct target_ops exec_ops
;
2231 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
2242 /* This will be passed to qsort to sort the results of the disassembly */
2245 compare_lines (mle1p
, mle2p
)
2249 struct my_line_entry
*mle1
, *mle2
;
2252 mle1
= (struct my_line_entry
*) mle1p
;
2253 mle2
= (struct my_line_entry
*) mle2p
;
2255 val
= mle1
->line
- mle2
->line
;
2260 return mle1
->start_pc
- mle2
->start_pc
;
2263 /* This implements the TCL command `gdb_loc',
2266 * ?symbol? The symbol or address to locate - defaults to pc
2268 * a list consisting of the following:
2269 * basename, function name, filename, line number, address, current pc
2273 gdb_loc (clientData
, interp
, objc
, objv
)
2274 ClientData clientData
;
2277 Tcl_Obj
*CONST objv
[];
2280 struct symtab_and_line sal
;
2281 char *funcname
, *fname
;
2284 if (!have_full_symbols () && !have_partial_symbols ())
2286 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No symbol table is loaded", -1);
2292 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
2294 /* Note - this next line is not correct on all architectures. */
2295 /* For a graphical debugger we really want to highlight the */
2296 /* assembly line that called the next function on the stack. */
2297 /* Many architectures have the next instruction saved as the */
2298 /* pc on the stack, so what happens is the next instruction is hughlighted. */
2300 pc
= selected_frame
->pc
;
2301 sal
= find_pc_line (selected_frame
->pc
,
2302 selected_frame
->next
!= NULL
2303 && !selected_frame
->next
->signal_handler_caller
2304 && !frame_in_dummy (selected_frame
->next
));
2309 sal
= find_pc_line (stop_pc
, 0);
2314 struct symtabs_and_lines sals
;
2317 sals
= decode_line_spec (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
2323 if (sals
.nelts
!= 1)
2325 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Ambiguous line spec", -1);
2332 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
2337 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2338 Tcl_NewStringObj (sal
.symtab
->filename
, -1));
2340 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewStringObj ("", 0));
2342 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
2343 fname
= cplus_demangle (funcname
, 0);
2346 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2347 Tcl_NewStringObj (fname
, -1));
2351 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2352 Tcl_NewStringObj (funcname
, -1));
2354 filename
= symtab_to_filename (sal
.symtab
);
2355 if (filename
== NULL
)
2358 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2359 Tcl_NewStringObj (filename
, -1));
2360 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(sal
.line
)); /* line number */
2361 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
2362 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
2366 /* This implements the Tcl command 'gdb_get_mem', which
2367 * dumps a block of memory
2369 * gdb_get_mem addr form size num aschar
2371 * addr: address of data to dump
2372 * form: a char indicating format
2373 * size: size of each element; 1,2,4, or 8 bytes
2374 * num: the number of bytes to read
2375 * acshar: an optional ascii character to use in ASCII dump
2378 * a list of elements followed by an optional ASCII dump
2382 gdb_get_mem (clientData
, interp
, objc
, objv
)
2383 ClientData clientData
;
2386 Tcl_Obj
*CONST objv
[];
2388 int size
, asize
, i
, j
, bc
;
2390 int nbytes
, rnum
, bpr
;
2392 char format
, c
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
2393 struct type
*val_type
;
2395 if (objc
< 6 || objc
> 7)
2397 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2398 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2402 if (Tcl_GetIntFromObj (interp
, objv
[3], &size
) != TCL_OK
)
2404 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2409 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid size, must be > 0", -1);
2413 if (Tcl_GetIntFromObj (interp
, objv
[4], &nbytes
) != TCL_OK
)
2415 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2420 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid number of bytes, must be > 0",
2425 if (Tcl_GetIntFromObj (interp
, objv
[5], &bpr
) != TCL_OK
)
2427 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2432 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid bytes per row, must be > 0", -1);
2436 if (Tcl_GetLongFromObj (interp
, objv
[1], &tmp
) != TCL_OK
)
2439 addr
= (CORE_ADDR
) tmp
;
2441 format
= *(Tcl_GetStringFromObj (objv
[2], NULL
));
2442 mbuf
= (char *)malloc (nbytes
+32);
2445 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Out of memory.", -1);
2449 memset (mbuf
, 0, nbytes
+32);
2452 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
2455 aschar
= *(Tcl_GetStringFromObj(objv
[6], NULL
));
2461 val_type
= builtin_type_char
;
2465 val_type
= builtin_type_short
;
2469 val_type
= builtin_type_int
;
2473 val_type
= builtin_type_long_long
;
2477 val_type
= builtin_type_char
;
2481 bc
= 0; /* count of bytes in a row */
2482 buff
[0] = '"'; /* buffer for ascii dump */
2483 bptr
= &buff
[1]; /* pointer for ascii dump */
2485 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Build up the result as a list... */
2487 for (i
=0; i
< nbytes
; i
+= size
)
2491 fputs_unfiltered ("N/A ", gdb_stdout
);
2493 for ( j
= 0; j
< size
; j
++)
2498 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
2502 for ( j
= 0; j
< size
; j
++)
2505 if (c
< 32 || c
> 126)
2517 if (aschar
&& (bc
>= bpr
))
2519 /* end of row. print it and reset variables */
2524 fputs_unfiltered (buff
, gdb_stdout
);
2529 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
2537 /* This implements the tcl command "gdb_loadfile"
2538 * It loads a c source file into a text widget.
2541 * widget: the name of the text widget to fill
2542 * filename: the name of the file to load
2543 * linenumbers: A boolean indicating whether or not to display line numbers.
2548 /* In this routine, we will build up a "line table", i.e. a
2549 * table of bits showing which lines in the source file are executible.
2550 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2552 * Its size limits the maximum number of lines
2553 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2554 * the file is loaded, so it is OK to make this very large.
2555 * Additional memory will be allocated if needed. */
2556 #define LTABLE_SIZE 20000
2558 gdb_loadfile (clientData
, interp
, objc
, objv
)
2559 ClientData clientData
;
2562 Tcl_Obj
*CONST objv
[];
2564 char *file
, *widget
;
2565 int linenumbers
, ln
, lnum
, ltable_size
;
2568 struct symtab
*symtab
;
2569 struct linetable_entry
*le
;
2572 Tcl_DString text_cmd_1
, text_cmd_2
, *cur_cmd
;
2573 char line
[1024], line_num_buf
[16];
2574 int prefix_len_1
, prefix_len_2
, cur_prefix_len
, widget_len
;
2579 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
2583 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
2584 if ( Tk_NameToWindow (interp
, widget
, Tk_MainWindow (interp
)) == NULL
)
2589 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
2590 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
2592 symtab
= full_lookup_symtab (file
);
2595 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "File not found in symtab", -1);
2600 file
= symtab_to_filename ( symtab
);
2601 if ((fp
= fopen ( file
, "r" )) == NULL
)
2603 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Can't open file for reading", -1);
2607 if (stat (file
, &st
) < 0)
2609 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
2614 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
2615 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
2617 mtime
= bfd_get_mtime(exec_bfd
);
2619 if (mtime
&& mtime
< st
.st_mtime
)
2620 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2623 /* Source linenumbers don't appear to be in order, and a sort is */
2624 /* too slow so the fastest solution is just to allocate a huge */
2625 /* array and set the array entry for each linenumber */
2627 ltable_size
= LTABLE_SIZE
;
2628 ltable
= (char *)malloc (LTABLE_SIZE
);
2631 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2636 memset (ltable
, 0, LTABLE_SIZE
);
2638 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
2640 le
= symtab
->linetable
->item
;
2641 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
2643 lnum
= le
->line
>> 3;
2644 if (lnum
>= ltable_size
)
2647 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
2648 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
2650 if (new_ltable
== NULL
)
2652 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2657 ltable
= new_ltable
;
2659 ltable
[lnum
] |= 1 << (le
->line
% 8);
2663 Tcl_DStringInit(&text_cmd_1
);
2664 Tcl_DStringInit(&text_cmd_2
);
2668 widget_len
= strlen (widget
);
2671 Tcl_DStringAppend (&text_cmd_1
, widget
, widget_len
);
2672 Tcl_DStringAppend (&text_cmd_2
, widget
, widget_len
);
2676 Tcl_DStringAppend (&text_cmd_1
, " insert end {-\t", -1);
2677 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2679 Tcl_DStringAppend (&text_cmd_2
, " insert end { \t", -1);
2680 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2682 while (fgets (line
+ 1, 980, fp
))
2684 sprintf (line_num_buf
, "%d", ln
);
2685 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2687 cur_cmd
= &text_cmd_1
;
2688 cur_prefix_len
= prefix_len_1
;
2689 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2690 Tcl_DStringAppend (cur_cmd
, "} break_tag", 11);
2694 cur_cmd
= &text_cmd_2
;
2695 cur_prefix_len
= prefix_len_2
;
2696 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2697 Tcl_DStringAppend (cur_cmd
, "} \"\"", 4);
2700 Tcl_DStringAppendElement (cur_cmd
, line
);
2701 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2703 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2704 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2710 Tcl_DStringAppend (&text_cmd_1
, " insert end {- } break_tag", -1);
2711 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2712 Tcl_DStringAppend (&text_cmd_2
, " insert end { } \"\"", -1);
2713 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2715 while (fgets (line
+ 1, 980, fp
))
2717 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2719 cur_cmd
= &text_cmd_1
;
2720 cur_prefix_len
= prefix_len_1
;
2724 cur_cmd
= &text_cmd_2
;
2725 cur_prefix_len
= prefix_len_2
;
2728 Tcl_DStringAppendElement (cur_cmd
, line
);
2729 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2731 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2732 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2738 Tcl_DStringFree (&text_cmd_1
);
2739 Tcl_DStringFree (&text_cmd_2
);
2746 * This section contains commands for manipulation of breakpoints.
2750 /* set a breakpoint by source file and line number */
2751 /* flags are as follows: */
2752 /* least significant 2 bits are disposition, rest is */
2753 /* type (normally 0).
2756 bp_breakpoint, Normal breakpoint
2757 bp_hardware_breakpoint, Hardware assisted breakpoint
2760 Disposition of breakpoint. Ie: what to do after hitting it.
2763 del_at_next_stop, Delete at next stop, whether hit or not
2765 donttouch Leave it alone
2769 /* This implements the tcl command "gdb_set_bp"
2770 * It sets breakpoints, and runs the Tcl command
2771 * gdbtk_tcl_breakpoint create
2772 * to register the new breakpoint with the GUI.
2775 * filename: the file in which to set the breakpoint
2776 * line: the line number for the breakpoint
2777 * type: the type of the breakpoint
2779 * The return value of the call to gdbtk_tcl_breakpoint.
2783 gdb_set_bp (clientData
, interp
, objc
, objv
)
2784 ClientData clientData
;
2787 Tcl_Obj
*CONST objv
[];
2790 struct symtab_and_line sal
;
2791 int line
, flags
, ret
;
2792 struct breakpoint
*b
;
2798 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
2802 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
2803 if (sal
.symtab
== NULL
)
2806 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
2808 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2812 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
2814 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2819 if (!find_line_pc (sal
.symtab
, sal
.line
, &sal
.pc
))
2822 sal
.section
= find_pc_overlay (sal
.pc
);
2823 b
= set_raw_breakpoint (sal
);
2824 set_breakpoint_count (breakpoint_count
+ 1);
2825 b
->number
= breakpoint_count
;
2826 b
->type
= flags
>> 2;
2827 b
->disposition
= flags
& 3;
2829 /* FIXME: this won't work for duplicate basenames! */
2830 sprintf (buf
, "%s:%d", basename (Tcl_GetStringFromObj ( objv
[1], NULL
)), line
);
2831 b
->addr_string
= strsave (buf
);
2833 /* now send notification command back to GUI */
2835 Tcl_DStringInit (&cmd
);
2837 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2838 sprintf (buf
, "%d", b
->number
);
2839 Tcl_DStringAppendElement(&cmd
, buf
);
2840 sprintf (buf
, "0x%lx", (long)sal
.pc
);
2841 Tcl_DStringAppendElement (&cmd
, buf
);
2842 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[2], NULL
));
2843 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[1], NULL
));
2845 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2846 Tcl_DStringFree (&cmd
);
2850 /* This implements the tcl command gdb_get_breakpoint_info
2856 * A list with {file, function, line_number, address, type, enabled?,
2857 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
2861 gdb_get_breakpoint_info (clientData
, interp
, objc
, objv
)
2862 ClientData clientData
;
2865 Tcl_Obj
*CONST objv
[];
2867 struct symtab_and_line sal
;
2868 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
2869 "finish", "watchpoint", "hardware watchpoint",
2870 "read watchpoint", "access watchpoint",
2871 "longjmp", "longjmp resume", "step resume",
2872 "through sigtramp", "watchpoint scope",
2874 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
2875 struct command_line
*cmd
;
2877 struct breakpoint
*b
;
2878 extern struct breakpoint
*breakpoint_chain
;
2879 char *funcname
, *fname
, *filename
;
2884 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong number of args, should be \"breakpoint\"", -1);
2888 if ( Tcl_GetIntFromObj(NULL
, objv
[1], &bpnum
) != TCL_OK
)
2890 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2894 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2895 if (b
->number
== bpnum
)
2898 if (!b
|| b
->type
!= bp_breakpoint
)
2900 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Breakpoint #%d does not exist", -1);
2904 sal
= find_pc_line (b
->address
, 0);
2906 filename
= symtab_to_filename (sal
.symtab
);
2907 if (filename
== NULL
)
2910 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
2911 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2912 Tcl_NewStringObj (filename
, -1));
2914 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
2915 fname
= cplus_demangle (funcname
, 0);
2918 new_obj
= Tcl_NewStringObj (fname
, -1);
2922 new_obj
= Tcl_NewStringObj (funcname
, -1);
2924 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2926 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->line_number
));
2927 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%lx", b
->address
);
2928 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2929 Tcl_NewStringObj (bptypes
[b
->type
], -1));
2930 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewBooleanObj(b
->enable
== enabled
));
2931 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2932 Tcl_NewStringObj (bpdisp
[b
->disposition
], -1));
2933 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->ignore_count
));
2935 new_obj
= Tcl_NewObj();
2936 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
2937 Tcl_ListObjAppendElement (NULL
, new_obj
,
2938 Tcl_NewStringObj (cmd
->line
, -1));
2939 Tcl_ListObjAppendElement(NULL
, result_ptr
->obj_ptr
, new_obj
);
2941 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2942 Tcl_NewStringObj (b
->cond_string
, -1));
2944 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->thread
));
2945 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->hit_count
));
2951 /* This implements the tcl command gdb_get_breakpoint_list
2952 * It builds up a list of the current breakpoints.
2957 * A list of breakpoint numbers.
2961 gdb_get_breakpoint_list (clientData
, interp
, objc
, objv
)
2962 ClientData clientData
;
2965 Tcl_Obj
*CONST objv
[];
2967 struct breakpoint
*b
;
2968 extern struct breakpoint
*breakpoint_chain
;
2972 error ("wrong number of args, none are allowed");
2974 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2975 if (b
->type
== bp_breakpoint
)
2977 new_obj
= Tcl_NewIntObj (b
->number
);
2978 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2984 /* The functions in this section deal with stacks and backtraces. */
2986 /* This implements the tcl command gdb_stack.
2987 * It builds up a list of stack frames.
2990 * start - starting stack frame
2991 * count - number of frames to inspect
2993 * A list of function names
2997 gdb_stack (clientData
, interp
, objc
, objv
) ClientData clientData
;
3000 Tcl_Obj
*CONST objv
[];
3006 Tcl_WrongNumArgs (interp
, 1, objv
, "start count");
3007 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3011 if (Tcl_GetIntFromObj (NULL
, objv
[1], &start
))
3013 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3016 if (Tcl_GetIntFromObj (NULL
, objv
[2], &count
))
3018 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3022 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
3024 if (target_has_stack
)
3026 struct frame_info
*top
;
3027 struct frame_info
*fi
;
3029 /* Find the outermost frame */
3030 fi
= get_current_frame ();
3034 fi
= get_prev_frame (fi
);
3037 /* top now points to the top (outermost frame) of the
3038 stack, so point it to the requested start */
3040 top
= find_relative_frame (top
, &start
);
3042 /* If start != 0, then we have asked to start outputting
3043 frames beyond the innermost stack frame */
3047 while (fi
&& count
--)
3049 get_frame_name (interp
, result_ptr
->obj_ptr
, fi
);
3050 fi
= get_next_frame (fi
);
3058 /* A helper function for get_stack which adds information about
3059 * the stack frame FI to the caller's LIST.
3061 * This is stolen from print_frame_info in stack.c.
3064 get_frame_name (interp
, list
, fi
)
3067 struct frame_info
*fi
;
3069 struct symtab_and_line sal
;
3070 struct symbol
*func
= NULL
;
3071 register char *funname
= 0;
3072 enum language funlang
= language_unknown
;
3075 if (frame_in_dummy (fi
))
3077 objv
[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
3078 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3081 if (fi
->signal_handler_caller
)
3083 objv
[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
3084 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3089 find_pc_line (fi
->pc
,
3091 && !fi
->next
->signal_handler_caller
3092 && !frame_in_dummy (fi
->next
));
3094 func
= find_pc_function (fi
->pc
);
3097 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3099 && (SYMBOL_VALUE_ADDRESS (msymbol
)
3100 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
3103 funname
= SYMBOL_NAME (msymbol
);
3104 funlang
= SYMBOL_LANGUAGE (msymbol
);
3108 funname
= SYMBOL_NAME (func
);
3109 funlang
= SYMBOL_LANGUAGE (func
);
3114 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3115 if (msymbol
!= NULL
)
3117 funname
= SYMBOL_NAME (msymbol
);
3118 funlang
= SYMBOL_LANGUAGE (msymbol
);
3124 objv
[0] = Tcl_NewStringObj (funname
, -1);
3125 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3130 /* we have no convenient way to deal with this yet... */
3131 if (fi
->pc
!= sal
.pc
|| !sal
.symtab
)
3133 print_address_numeric (fi
->pc
, 1, gdb_stdout
);
3134 printf_filtered (" in ");
3136 printf_symbol_filtered (gdb_stdout
, funname
? funname
: "??", funlang
,
3139 objv
[0] = Tcl_NewStringObj (funname
!= NULL
? funname
: "??", -1);
3140 #ifdef PC_LOAD_SEGMENT
3141 /* If we couldn't print out function name but if can figure out what
3142 load segment this pc value is from, at least print out some info
3143 about its load segment. */
3146 Tcl_AppendStringsToObj (objv
[0], " from ", PC_LOAD_SEGMENT (fi
->pc
),
3153 char *lib
= PC_SOLIB (fi
->pc
);
3156 Tcl_AppendStringsToObj (objv
[0], " from ", lib
, (char *) NULL
);
3160 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3166 * This section contains a bunch of miscellaneous utility commands
3169 /* This implements the tcl command gdb_path_conv
3171 * On Windows, it canonicalizes the pathname,
3172 * On Unix, it is a no op.
3177 * The canonicalized path.
3181 gdb_path_conv (clientData
, interp
, objc
, objv
)
3182 ClientData clientData
;
3185 Tcl_Obj
*CONST objv
[];
3188 error ("wrong # args");
3192 char pathname
[256], *ptr
;
3194 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj(objv
[1], NULL
), pathname
);
3195 for (ptr
= pathname
; *ptr
; ptr
++)
3200 Tcl_SetStringObj (result_ptr
->obj_ptr
, pathname
, -1);
3203 Tcl_SetStringObj (result_ptr
->obj_ptr
, Tcl_GetStringFromObj (objv
[1], NULL
), -1);
3210 * This section has utility routines that are not Tcl commands.
3214 perror_with_name_wrapper (args
)
3217 perror_with_name (args
);
3221 /* The lookup_symtab() in symtab.c doesn't work correctly */
3222 /* It will not work will full pathnames and if multiple */
3223 /* source files have the same basename, it will return */
3224 /* the first one instead of the correct one. This version */
3225 /* also always makes sure symtab->fullname is set. */
3227 static struct symtab
*
3228 full_lookup_symtab(file
)
3232 struct objfile
*objfile
;
3233 char *bfile
, *fullname
;
3234 struct partial_symtab
*pt
;
3239 /* first try a direct lookup */
3240 st
= lookup_symtab (file
);
3244 symtab_to_filename(st
);
3248 /* if the direct approach failed, try */
3249 /* looking up the basename and checking */
3250 /* all matches with the fullname */
3251 bfile
= basename (file
);
3252 ALL_SYMTABS (objfile
, st
)
3254 if (!strcmp (bfile
, basename(st
->filename
)))
3257 fullname
= symtab_to_filename (st
);
3259 fullname
= st
->fullname
;
3261 if (!strcmp (file
, fullname
))
3266 /* still no luck? look at psymtabs */
3267 ALL_PSYMTABS (objfile
, pt
)
3269 if (!strcmp (bfile
, basename(pt
->filename
)))
3271 st
= PSYMTAB_TO_SYMTAB (pt
);
3274 fullname
= symtab_to_filename (st
);
3275 if (!strcmp (file
, fullname
))