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))
671 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
672 load_in_progress
= 1;
675 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
677 if (load_in_progress
)
679 load_in_progress
= 0;
680 result_ptr
->flags
|= GDBTK_TO_RESULT
;
683 bpstat_do_actions (&stop_bpstat
);
689 * This implements the tcl command "gdb_immediate"
691 * It does exactly the same thing as gdb_cmd, except NONE of its outut
692 * is buffered. This will also ALWAYS cause the busy, update, and idle hooks to
693 * be called, contrasted with gdb_cmd, which NEVER calls them.
694 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
695 * to the console window.
698 * command - The GDB command to execute
704 gdb_immediate_command (clientData
, interp
, objc
, objv
)
705 ClientData clientData
;
708 Tcl_Obj
*CONST objv
[];
713 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
717 if (running_now
|| load_in_progress
)
722 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
724 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
726 bpstat_do_actions (&stop_bpstat
);
728 result_ptr
->flags
|= GDBTK_TO_RESULT
;
733 /* This implements the tcl command "gdb_prompt"
735 * It returns the gdb interpreter's prompt.
744 gdb_prompt_command (clientData
, interp
, objc
, objv
)
745 ClientData clientData
;
748 Tcl_Obj
*CONST objv
[];
750 Tcl_SetStringObj (result_ptr
->obj_ptr
, get_prompt (), -1);
756 * This section contains general informational commands.
759 /* This implements the tcl command "gdb_target_has_execution"
761 * Tells whether the target is executing.
766 * A boolean indicating whether the target is executing.
770 gdb_target_has_execution_command (clientData
, interp
, objc
, objv
)
771 ClientData clientData
;
774 Tcl_Obj
*CONST objv
[];
778 if (target_has_execution
&& inferior_pid
!= 0)
781 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, result
);
785 /* This implements the tcl command "gdb_load_info"
787 * It returns information about the file about to be downloaded.
790 * filename: The file to open & get the info on.
792 * A list consisting of the name and size of each section.
796 gdb_load_info (clientData
, interp
, objc
, objv
)
797 ClientData clientData
;
800 Tcl_Obj
*CONST objv
[];
803 struct cleanup
*old_cleanups
;
807 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
809 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
810 if (loadfile_bfd
== NULL
)
812 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Open failed", -1);
815 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
817 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
819 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Bad Object File", -1);
823 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
825 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
827 if (s
->flags
& SEC_LOAD
)
829 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
832 ob
[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd
, s
), -1);
833 ob
[1] = Tcl_NewLongObj ((long) size
);
834 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewListObj (2, ob
));
839 do_cleanups (old_cleanups
);
845 * This and gdb_get_locals just call gdb_get_vars_command with the right
846 * value of clientData. We can't use the client data in the definition
847 * of the command, because the call wrapper uses this instead...
851 gdb_get_locals_command (clientData
, interp
, objc
, objv
)
852 ClientData clientData
;
855 Tcl_Obj
*CONST objv
[];
858 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
863 gdb_get_args_command (clientData
, interp
, objc
, objv
)
864 ClientData clientData
;
867 Tcl_Obj
*CONST objv
[];
870 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
874 /* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
876 * This function sets the Tcl interpreter's result to a list of variable names
877 * depending on clientData. If clientData is one, the result is a list of
878 * arguments; zero returns a list of locals -- all relative to the block
879 * specified as an argument to the command. Valid commands include
880 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
884 * block - the address within which to specify the locals or args.
886 * A list of the locals or args
890 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
891 ClientData clientData
;
894 Tcl_Obj
*CONST objv
[];
896 struct symtabs_and_lines sals
;
899 char **canonical
, *args
;
900 int i
, nsyms
, arguments
;
904 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
,
905 "wrong # of args: should be \"",
906 Tcl_GetStringFromObj (objv
[0], NULL
),
907 " function:line|function|line|*addr\"", NULL
);
911 arguments
= (int) clientData
;
912 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
913 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
916 Tcl_SetStringObj (result_ptr
->obj_ptr
,
917 "error decoding line", -1);
921 /* Initialize the result pointer to an empty list. */
923 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
925 /* Resolve all line numbers to PC's */
926 for (i
= 0; i
< sals
.nelts
; i
++)
927 resolve_sal_pc (&sals
.sals
[i
]);
929 block
= block_for_pc (sals
.sals
[0].pc
);
932 nsyms
= BLOCK_NSYMS (block
);
933 for (i
= 0; i
< nsyms
; i
++)
935 sym
= BLOCK_SYM (block
, i
);
936 switch (SYMBOL_CLASS (sym
)) {
938 case LOC_UNDEF
: /* catches errors */
939 case LOC_CONST
: /* constant */
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 */
959 case LOC_STATIC
: /* static */
960 case LOC_REGISTER
: /* register */
962 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
963 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
967 if (BLOCK_FUNCTION (block
))
970 block
= BLOCK_SUPERBLOCK (block
);
976 /* This implements the tcl command "gdb_get_line"
978 * It returns the linenumber for a given linespec. It will take any spec
979 * that can be passed to decode_line_1
982 * linespec - the line specification
984 * The line number for that spec.
987 gdb_get_line_command (clientData
, interp
, objc
, objv
)
988 ClientData clientData
;
991 Tcl_Obj
*CONST objv
[];
993 struct symtabs_and_lines sals
;
994 char *args
, **canonical
;
998 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
999 Tcl_GetStringFromObj (objv
[0], NULL
),
1000 " linespec\"", NULL
);
1004 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1005 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1006 if (sals
.nelts
== 1)
1008 Tcl_SetIntObj (result_ptr
->obj_ptr
, sals
.sals
[0].line
);
1012 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1017 /* This implements the tcl command "gdb_get_file"
1019 * It returns the file containing a given line spec.
1022 * linespec - The linespec to look up
1024 * The file containing it.
1028 gdb_get_file_command (clientData
, interp
, objc
, objv
)
1029 ClientData clientData
;
1032 Tcl_Obj
*CONST objv
[];
1034 struct symtabs_and_lines sals
;
1035 char *args
, **canonical
;
1039 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1040 Tcl_GetStringFromObj (objv
[0], NULL
),
1041 " linespec\"", NULL
);
1045 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1046 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1047 if (sals
.nelts
== 1)
1049 Tcl_SetStringObj (result_ptr
->obj_ptr
, sals
.sals
[0].symtab
->filename
, -1);
1053 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1057 /* This implements the tcl command "gdb_get_function"
1059 * It finds the function containing the given line spec.
1062 * linespec - The line specification
1064 * The function that contains it, or "N/A" if it is not in a function.
1067 gdb_get_function_command (clientData
, interp
, objc
, objv
)
1068 ClientData clientData
;
1071 Tcl_Obj
*CONST objv
[];
1074 struct symtabs_and_lines sals
;
1075 char *args
, **canonical
;
1079 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1080 Tcl_GetStringFromObj (objv
[0], NULL
),
1081 " linespec\"", NULL
);
1085 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1086 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1087 if (sals
.nelts
== 1)
1089 resolve_sal_pc (&sals
.sals
[0]);
1090 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
1091 if (function
!= NULL
)
1093 Tcl_SetStringObj (result_ptr
->obj_ptr
, function
, -1);
1098 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1102 /* This implements the tcl command "gdb_find_file"
1104 * It searches the symbol tables to get the full pathname to a file.
1107 * filename: the file name to search for.
1109 * The full path to the file, or an empty string if the file is not
1114 gdb_find_file_command (clientData
, interp
, objc
, objv
)
1115 ClientData clientData
;
1118 Tcl_Obj
*CONST objv
[];
1120 char *filename
= NULL
;
1125 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
1129 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1131 filename
= st
->fullname
;
1133 if (filename
== NULL
)
1134 Tcl_SetStringObj (result_ptr
->obj_ptr
, "", 0);
1136 Tcl_SetStringObj (result_ptr
->obj_ptr
, filename
, -1);
1141 /* This implements the tcl command "gdb_listfiles"
1143 * This lists all the files in the current executible.
1145 * Note that this currently pulls in all sorts of filenames
1146 * that aren't really part of the executable. It would be
1147 * best if we could check each file to see if it actually
1148 * contains executable lines of code, but we can't do that
1152 * ?pathname? - If provided, only files which match pathname
1153 * (up to strlen(pathname)) are included. THIS DOES NOT
1154 * CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1155 * THE FULL PATHNAME!!!
1158 * A list of all matching files.
1161 gdb_listfiles (clientData
, interp
, objc
, objv
)
1162 ClientData clientData
;
1165 Tcl_Obj
*CONST objv
[];
1167 struct objfile
*objfile
;
1168 struct partial_symtab
*psymtab
;
1169 struct symtab
*symtab
;
1170 char *lastfile
, *pathname
=NULL
, **files
;
1172 int i
, numfiles
= 0, len
= 0;
1175 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1179 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1183 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1185 ALL_PSYMTABS (objfile
, psymtab
)
1187 if (numfiles
== files_size
)
1189 files_size
= files_size
* 2;
1190 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1192 if (psymtab
->filename
)
1194 if (!len
|| !strncmp(pathname
, psymtab
->filename
,len
)
1195 || !strcmp(psymtab
->filename
, basename(psymtab
->filename
)))
1197 files
[numfiles
++] = basename(psymtab
->filename
);
1202 ALL_SYMTABS (objfile
, symtab
)
1204 if (numfiles
== files_size
)
1206 files_size
= files_size
* 2;
1207 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1209 if (symtab
->filename
&& symtab
->linetable
&& symtab
->linetable
->nitems
)
1211 if (!len
|| !strncmp(pathname
, symtab
->filename
,len
)
1212 || !strcmp(symtab
->filename
, basename(symtab
->filename
)))
1214 files
[numfiles
++] = basename(symtab
->filename
);
1219 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1223 /* Discard the old result pointer, in case it has accumulated anything
1224 and set it to a new list object */
1226 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1228 for (i
= 0; i
< numfiles
; i
++)
1230 if (strcmp(files
[i
],lastfile
))
1231 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj(files
[i
], -1));
1232 lastfile
= files
[i
];
1240 comp_files (file1
, file2
)
1241 const void *file1
, *file2
;
1243 return strcmp(* (char **) file1
, * (char **) file2
);
1247 /* This implements the tcl command "gdb_search"
1251 * option - One of "functions", "variables" or "types"
1252 * regexp - The regular expression to look for.
1261 gdb_search (clientData
, interp
, objc
, objv
)
1262 ClientData clientData
;
1265 Tcl_Obj
*CONST objv
[];
1267 struct symbol_search
*ss
= NULL
;
1268 struct symbol_search
*p
;
1269 struct cleanup
*old_chain
= NULL
;
1270 Tcl_Obj
*CONST
*switch_objv
;
1271 int index
, switch_objc
, i
;
1272 namespace_enum space
= 0;
1274 int static_only
, nfiles
;
1275 Tcl_Obj
**file_list
;
1277 static char *search_options
[] = { "functions", "variables", "types", (char *) NULL
};
1278 static char *switches
[] = { "-files", "-static", (char *) NULL
};
1279 enum search_opts
{ SEARCH_FUNCTIONS
, SEARCH_VARIABLES
, SEARCH_TYPES
};
1280 enum switches_opts
{ SWITCH_FILES
, SWITCH_STATIC_ONLY
};
1284 Tcl_WrongNumArgs (interp
, 1, objv
, "option regexp ?arg ...?");
1285 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1289 if (Tcl_GetIndexFromObj (interp
, objv
[1], search_options
, "option", 0,
1292 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1296 /* Unfortunately, we cannot teach search_symbols to search on
1297 multiple regexps, so we have to do a two-tier search for
1298 any searches which choose to narrow the playing field. */
1299 switch ((enum search_opts
) index
)
1301 case SEARCH_FUNCTIONS
:
1302 space
= FUNCTIONS_NAMESPACE
; break;
1303 case SEARCH_VARIABLES
:
1304 space
= VARIABLES_NAMESPACE
; break;
1306 space
= TYPES_NAMESPACE
; break;
1309 regexp
= Tcl_GetStringFromObj (objv
[2], NULL
);
1310 /* Process any switches that refine the search */
1311 switch_objc
= objc
- 3;
1312 switch_objv
= objv
+ 3;
1316 files
= (char **) NULL
;
1317 while (switch_objc
> 0)
1319 if (Tcl_GetIndexFromObj (interp
, switch_objv
[0], switches
,
1320 "option", 0, &index
) != TCL_OK
)
1322 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1326 switch ((enum switches_opts
) index
)
1331 if (switch_objc
< 2)
1333 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList -static 1|0]");
1334 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1337 result
= Tcl_ListObjGetElements (interp
, switch_objv
[1], &nfiles
, &file_list
);
1338 if (result
!= TCL_OK
)
1341 files
= (char **) xmalloc (nfiles
* sizeof (char *));
1342 for (i
= 0; i
< nfiles
; i
++)
1343 files
[i
] = Tcl_GetStringFromObj (file_list
[i
], NULL
);
1348 case SWITCH_STATIC_ONLY
:
1349 if (switch_objc
< 2)
1351 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList] [-static 1|0]");
1352 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1355 if ( Tcl_GetBooleanFromObj (interp
, switch_objv
[1], &static_only
) !=
1357 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1367 search_symbols (regexp
, space
, nfiles
, files
, &ss
);
1369 old_chain
= make_cleanup (free_search_symbols
, ss
);
1371 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1373 for (p
= ss
; p
!= NULL
; p
= p
->next
)
1377 if (static_only
&& p
->block
!= STATIC_BLOCK
)
1380 elem
= Tcl_NewListObj (0, NULL
);
1382 if (p
->msymbol
== NULL
)
1383 Tcl_ListObjAppendElement (interp
, elem
,
1384 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->symbol
), -1));
1386 Tcl_ListObjAppendElement (interp
, elem
,
1387 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->msymbol
), -1));
1389 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, elem
);
1393 do_cleanups (old_chain
);
1398 /* This implements the tcl command gdb_listfuncs
1400 * It lists all the functions defined in a given file
1403 * file - the file to look in
1405 * A list of two element lists, the first element is
1406 * the symbol name, and the second is a boolean indicating
1407 * whether the symbol is demangled (1 for yes).
1411 gdb_listfuncs (clientData
, interp
, objc
, objv
)
1412 ClientData clientData
;
1415 Tcl_Obj
*CONST objv
[];
1417 struct symtab
*symtab
;
1418 struct blockvector
*bv
;
1422 Tcl_Obj
*funcVals
[2];
1426 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1429 symtab
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1432 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No such file", -1);
1436 if (mangled
== NULL
)
1438 mangled
= Tcl_NewBooleanObj(1);
1439 not_mangled
= Tcl_NewBooleanObj(0);
1440 Tcl_IncrRefCount(mangled
);
1441 Tcl_IncrRefCount(not_mangled
);
1444 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1446 bv
= BLOCKVECTOR (symtab
);
1447 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1449 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1450 /* Skip the sort if this block is always sorted. */
1451 if (!BLOCK_SHOULD_SORT (b
))
1452 sort_block_syms (b
);
1453 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1455 sym
= BLOCK_SYM (b
, j
);
1456 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1459 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1462 /* strip out "global constructors" and "global destructors" */
1463 /* because we aren't interested in them. */
1464 if (strncmp (name
, "global ", 7))
1466 funcVals
[0] = Tcl_NewStringObj(name
, -1);
1467 funcVals
[1] = mangled
;
1475 funcVals
[0] = Tcl_NewStringObj(SYMBOL_NAME(sym
), -1);
1476 funcVals
[1] = not_mangled
;
1478 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1479 Tcl_NewListObj (2, funcVals
));
1488 * This section contains all the commands that act on the registers:
1491 /* This is a sort of mapcar function for operations on registers */
1494 map_arg_registers (objc
, objv
, func
, argp
)
1496 Tcl_Obj
*CONST objv
[];
1497 void (*func
) PARAMS ((int regnum
, void *argp
));
1502 /* Note that the test for a valid register must include checking the
1503 reg_names array because NUM_REGS may be allocated for the union of the
1504 register sets within a family of related processors. In this case, the
1505 trailing entries of reg_names will change depending upon the particular
1506 processor being debugged. */
1508 if (objc
== 0) /* No args, just do all the regs */
1512 && reg_names
[regnum
] != NULL
1513 && *reg_names
[regnum
] != '\000';
1515 func (regnum
, argp
);
1520 /* Else, list of register #s, just do listed regs */
1521 for (; objc
> 0; objc
--, objv
++)
1523 if (Tcl_GetIntFromObj (NULL
, *objv
, ®num
) != TCL_OK
)
1525 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1530 && regnum
< NUM_REGS
1531 && reg_names
[regnum
] != NULL
1532 && *reg_names
[regnum
] != '\000')
1533 func (regnum
, argp
);
1536 Tcl_SetStringObj (result_ptr
->obj_ptr
, "bad register number", -1);
1544 /* This implements the TCL command `gdb_regnames', which returns a list of
1545 all of the register names. */
1548 gdb_regnames (clientData
, interp
, objc
, objv
)
1549 ClientData clientData
;
1552 Tcl_Obj
*CONST objv
[];
1557 return map_arg_registers (objc
, objv
, get_register_name
, NULL
);
1561 get_register_name (regnum
, argp
)
1563 void *argp
; /* Ignored */
1565 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1566 Tcl_NewStringObj (reg_names
[regnum
], -1));
1569 /* This implements the tcl command gdb_fetch_registers
1570 * Pass it a list of register names, and it will
1571 * return their values as a list.
1574 * format: The format string for printing the values
1575 * args: the registers to look for
1577 * A list of their values.
1581 gdb_fetch_registers (clientData
, interp
, objc
, objv
)
1582 ClientData clientData
;
1585 Tcl_Obj
*CONST objv
[];
1591 Tcl_SetStringObj (result_ptr
->obj_ptr
,
1592 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
1596 format
= *(Tcl_GetStringFromObj(objv
[0], NULL
));
1600 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Output the results as a list */
1601 result
= map_arg_registers (objc
, objv
, get_register
, (void *) format
);
1602 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
1608 get_register (regnum
, fp
)
1612 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1613 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
1614 int format
= (int)fp
;
1619 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1621 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1622 Tcl_NewStringObj ("Optimized out", -1));
1626 /* Convert raw data to virtual format if necessary. */
1628 if (REGISTER_CONVERTIBLE (regnum
))
1630 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
1631 raw_buffer
, virtual_buffer
);
1634 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1639 printf_filtered ("0x");
1640 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1642 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1643 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1644 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
1648 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
1649 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1653 /* This implements the tcl command get_pc_reg
1654 * It returns the value of the PC register
1659 * The value of the pc register.
1663 get_pc_register (clientData
, interp
, objc
, objv
)
1664 ClientData clientData
;
1667 Tcl_Obj
*CONST objv
[];
1671 sprintf (buff
, "0x%llx",(long long) read_register (PC_REGNUM
));
1672 Tcl_SetStringObj(result_ptr
->obj_ptr
, buff
, -1);
1676 /* This implements the tcl command "gdb_changed_register_list"
1677 * It takes a list of registers, and returns a list of
1678 * the registers on that list that have changed since the last
1679 * time the proc was called.
1682 * A list of registers.
1684 * A list of changed registers.
1688 gdb_changed_register_list (clientData
, interp
, objc
, objv
)
1689 ClientData clientData
;
1692 Tcl_Obj
*CONST objv
[];
1697 return map_arg_registers (objc
, objv
, register_changed_p
, NULL
);
1701 register_changed_p (regnum
, argp
)
1703 void *argp
; /* Ignored */
1705 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1707 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1710 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1711 REGISTER_RAW_SIZE (regnum
)) == 0)
1714 /* Found a changed register. Save new value and return its number. */
1716 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1717 REGISTER_RAW_SIZE (regnum
));
1719 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(regnum
));
1723 * This section contains the commands that deal with tracepoints:
1726 /* return a list of all tracepoint numbers in interpreter */
1728 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
1729 ClientData clientData
;
1732 Tcl_Obj
*CONST objv
[];
1734 struct tracepoint
*tp
;
1736 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1738 ALL_TRACEPOINTS (tp
)
1739 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->number
));
1744 /* returns -1 if not found, tracepoint # if found */
1746 tracepoint_exists (char * args
)
1748 struct tracepoint
*tp
;
1750 struct symtabs_and_lines sals
;
1754 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1755 if (sals
.nelts
== 1)
1757 resolve_sal_pc (&sals
.sals
[0]);
1758 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
1759 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
1762 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
1763 strcat (file
, sals
.sals
[0].symtab
->filename
);
1765 ALL_TRACEPOINTS (tp
)
1767 if (tp
->address
== sals
.sals
[0].pc
)
1768 result
= tp
->number
;
1770 /* Why is this here? This messes up assembly traces */
1771 else if (tp
->source_file
!= NULL
1772 && strcmp (tp
->source_file
, file
) == 0
1773 && sals
.sals
[0].line
== tp
->line_number
)
1774 result
= tp
->number
;
1785 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
1786 ClientData clientData
;
1789 Tcl_Obj
*CONST objv
[];
1795 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1796 Tcl_GetStringFromObj (objv
[0], NULL
),
1797 " function:line|function|line|*addr\"", NULL
);
1801 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1803 Tcl_SetIntObj (result_ptr
->obj_ptr
, tracepoint_exists (args
));
1808 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
1809 ClientData clientData
;
1812 Tcl_Obj
*CONST objv
[];
1814 struct symtab_and_line sal
;
1816 struct tracepoint
*tp
;
1817 struct action_line
*al
;
1818 Tcl_Obj
*action_list
;
1819 char *filename
, *funcname
;
1824 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1828 if (Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
) != TCL_OK
)
1830 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1834 ALL_TRACEPOINTS (tp
)
1835 if (tp
->number
== tpnum
)
1840 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Tracepoint #%d does not exist", -1);
1844 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1845 sal
= find_pc_line (tp
->address
, 0);
1846 filename
= symtab_to_filename (sal
.symtab
);
1847 if (filename
== NULL
)
1849 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1850 Tcl_NewStringObj (filename
, -1));
1851 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
1852 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (funcname
, -1));
1853 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (sal
.line
));
1854 sprintf (tmp
, "0x%lx", tp
->address
);
1855 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (tmp
, -1));
1856 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->enabled
));
1857 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->pass_count
));
1858 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->step_count
));
1859 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->thread
));
1860 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->hit_count
));
1862 /* Append a list of actions */
1863 action_list
= Tcl_NewObj ();
1864 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
1866 Tcl_ListObjAppendElement (interp
, action_list
,
1867 Tcl_NewStringObj (al
->action
, -1));
1869 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, action_list
);
1876 gdb_trace_status (clientData
, interp
, objc
, objv
)
1877 ClientData clientData
;
1880 Tcl_Obj
*CONST objv
[];
1884 if (trace_running_p
)
1887 Tcl_SetIntObj (result_ptr
->obj_ptr
, result
);
1894 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
1895 ClientData clientData
;
1898 Tcl_Obj
*CONST objv
[];
1902 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1903 Tcl_GetStringFromObj (objv
[0], NULL
),
1904 " linespec\"", NULL
);
1908 Tcl_SetIntObj (result_ptr
->obj_ptr
, get_traceframe_number ());
1913 /* This implements the tcl command gdb_actions
1914 * It sets actions for a given tracepoint.
1917 * number: the tracepoint in question
1918 * actions: the actions to add to this tracepoint
1924 gdb_actions_command (clientData
, interp
, objc
, objv
)
1925 ClientData clientData
;
1928 Tcl_Obj
*CONST objv
[];
1930 struct tracepoint
*tp
;
1932 int nactions
, i
, len
;
1933 char *number
, *args
, *action
;
1935 struct action_line
*next
= NULL
, *temp
;
1936 enum actionline_type linetype
;
1940 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # args: should be: \"",
1941 Tcl_GetStringFromObj (objv
[0], NULL
),
1942 " number actions\"", NULL
);
1946 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
1947 tp
= get_tracepoint_by_number (&args
);
1950 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "Tracepoint \"", number
, "\" does not exist", NULL
);
1954 /* Free any existing actions */
1955 if (tp
->actions
!= NULL
)
1960 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
1962 /* Add the actions to the tracepoint */
1963 for (i
= 0; i
< nactions
; i
++)
1965 temp
= xmalloc (sizeof (struct action_line
));
1967 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
1968 temp
->action
= savestring (action
, len
);
1970 linetype
= validate_actionline (&(temp
->action
), tp
);
1972 if (linetype
== BADLINE
)
1994 * This section has commands that handle source disassembly.
1997 /* This implements the tcl command gdb_disassemble
2000 * source_with_assm - must be "source" or "nosource"
2001 * low_address - the address from which to start disassembly
2002 * ?hi_address? - the address to which to disassemble, defaults
2003 * to the end of the function containing low_address.
2005 * The disassembled code is passed to fputs_unfiltered, so it
2006 * either goes to the console if result_ptr->obj_ptr is NULL or to
2011 gdb_disassemble (clientData
, interp
, objc
, objv
)
2012 ClientData clientData
;
2015 Tcl_Obj
*CONST objv
[];
2017 CORE_ADDR pc
, low
, high
;
2018 int mixed_source_and_assembly
;
2019 static disassemble_info di
;
2020 static int di_initialized
;
2023 if (objc
!= 3 && objc
!= 4)
2024 error ("wrong # args");
2026 if (! di_initialized
)
2028 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
2029 (fprintf_ftype
) fprintf_unfiltered
);
2030 di
.flavour
= bfd_target_unknown_flavour
;
2031 di
.memory_error_func
= dis_asm_memory_error
;
2032 di
.print_address_func
= dis_asm_print_address
;
2036 di
.mach
= tm_print_insn_info
.mach
;
2037 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
2038 di
.endian
= BFD_ENDIAN_BIG
;
2040 di
.endian
= BFD_ENDIAN_LITTLE
;
2042 arg_ptr
= Tcl_GetStringFromObj (objv
[1], NULL
);
2043 if (*arg_ptr
== 's' && strcmp (arg_ptr
, "source") == 0)
2044 mixed_source_and_assembly
= 1;
2045 else if (*arg_ptr
== 'n' && strcmp (arg_ptr
, "nosource") == 0)
2046 mixed_source_and_assembly
= 0;
2048 error ("First arg must be 'source' or 'nosource'");
2050 low
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[2], NULL
));
2054 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
2055 error ("No function contains specified address");
2058 high
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[3], NULL
));
2060 /* If disassemble_from_exec == -1, then we use the following heuristic to
2061 determine whether or not to do disassembly from target memory or from the
2064 If we're debugging a local process, read target memory, instead of the
2065 exec file. This makes disassembly of functions in shared libs work
2068 Else, we're debugging a remote process, and should disassemble from the
2069 exec file for speed. However, this is no good if the target modifies its
2070 code (for relocation, or whatever).
2073 if (disassemble_from_exec
== -1)
2075 if (strcmp (target_shortname
, "child") == 0
2076 || strcmp (target_shortname
, "procfs") == 0
2077 || strcmp (target_shortname
, "vxprocess") == 0)
2078 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
2080 disassemble_from_exec
= 1; /* It's remote, read the exec file */
2083 if (disassemble_from_exec
)
2084 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
2086 di
.read_memory_func
= dis_asm_read_memory
;
2088 /* If just doing straight assembly, all we need to do is disassemble
2089 everything between low and high. If doing mixed source/assembly, we've
2090 got a totally different path to follow. */
2092 if (mixed_source_and_assembly
)
2093 { /* Come here for mixed source/assembly */
2094 /* The idea here is to present a source-O-centric view of a function to
2095 the user. This means that things are presented in source order, with
2096 (possibly) out of order assembly immediately following. */
2097 struct symtab
*symtab
;
2098 struct linetable_entry
*le
;
2101 struct my_line_entry
*mle
;
2102 struct symtab_and_line sal
;
2107 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
2109 if (!symtab
|| !symtab
->linetable
)
2112 /* First, convert the linetable to a bunch of my_line_entry's. */
2114 le
= symtab
->linetable
->item
;
2115 nlines
= symtab
->linetable
->nitems
;
2120 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
2124 /* Copy linetable entries for this function into our data structure, creating
2125 end_pc's and setting out_of_order as appropriate. */
2127 /* First, skip all the preceding functions. */
2129 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
2131 /* Now, copy all entries before the end of this function. */
2134 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
2136 if (le
[i
].line
== le
[i
+ 1].line
2137 && le
[i
].pc
== le
[i
+ 1].pc
)
2138 continue; /* Ignore duplicates */
2140 mle
[newlines
].line
= le
[i
].line
;
2141 if (le
[i
].line
> le
[i
+ 1].line
)
2143 mle
[newlines
].start_pc
= le
[i
].pc
;
2144 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
2148 /* If we're on the last line, and it's part of the function, then we need to
2149 get the end pc in a special way. */
2154 mle
[newlines
].line
= le
[i
].line
;
2155 mle
[newlines
].start_pc
= le
[i
].pc
;
2156 sal
= find_pc_line (le
[i
].pc
, 0);
2157 mle
[newlines
].end_pc
= sal
.end
;
2161 /* Now, sort mle by line #s (and, then by addresses within lines). */
2164 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
2166 /* Now, for each line entry, emit the specified lines (unless they have been
2167 emitted before), followed by the assembly code for that line. */
2169 next_line
= 0; /* Force out first line */
2170 for (i
= 0; i
< newlines
; i
++)
2172 /* Print out everything from next_line to the current line. */
2174 if (mle
[i
].line
>= next_line
)
2177 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
2179 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
2181 next_line
= mle
[i
].line
+ 1;
2184 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
2187 fputs_unfiltered (" ", gdb_stdout
);
2188 print_address (pc
, gdb_stdout
);
2189 fputs_unfiltered (":\t ", gdb_stdout
);
2190 pc
+= (*tm_print_insn
) (pc
, &di
);
2191 fputs_unfiltered ("\n", gdb_stdout
);
2198 for (pc
= low
; pc
< high
; )
2201 fputs_unfiltered (" ", gdb_stdout
);
2202 print_address (pc
, gdb_stdout
);
2203 fputs_unfiltered (":\t ", gdb_stdout
);
2204 pc
+= (*tm_print_insn
) (pc
, &di
);
2205 fputs_unfiltered ("\n", gdb_stdout
);
2209 gdb_flush (gdb_stdout
);
2214 /* This is the memory_read_func for gdb_disassemble when we are
2215 disassembling from the exec file. */
2218 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
2222 disassemble_info
*info
;
2224 extern struct target_ops exec_ops
;
2228 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
2239 /* This will be passed to qsort to sort the results of the disassembly */
2242 compare_lines (mle1p
, mle2p
)
2246 struct my_line_entry
*mle1
, *mle2
;
2249 mle1
= (struct my_line_entry
*) mle1p
;
2250 mle2
= (struct my_line_entry
*) mle2p
;
2252 val
= mle1
->line
- mle2
->line
;
2257 return mle1
->start_pc
- mle2
->start_pc
;
2260 /* This implements the TCL command `gdb_loc',
2263 * ?symbol? The symbol or address to locate - defaults to pc
2265 * a list consisting of the following:
2266 * basename, function name, filename, line number, address, current pc
2270 gdb_loc (clientData
, interp
, objc
, objv
)
2271 ClientData clientData
;
2274 Tcl_Obj
*CONST objv
[];
2277 struct symtab_and_line sal
;
2278 char *funcname
, *fname
;
2281 if (!have_full_symbols () && !have_partial_symbols ())
2283 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No symbol table is loaded", -1);
2289 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
2291 /* Note - this next line is not correct on all architectures. */
2292 /* For a graphical debugger we really want to highlight the */
2293 /* assembly line that called the next function on the stack. */
2294 /* Many architectures have the next instruction saved as the */
2295 /* pc on the stack, so what happens is the next instruction is hughlighted. */
2297 pc
= selected_frame
->pc
;
2298 sal
= find_pc_line (selected_frame
->pc
,
2299 selected_frame
->next
!= NULL
2300 && !selected_frame
->next
->signal_handler_caller
2301 && !frame_in_dummy (selected_frame
->next
));
2306 sal
= find_pc_line (stop_pc
, 0);
2311 struct symtabs_and_lines sals
;
2314 sals
= decode_line_spec (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
2320 if (sals
.nelts
!= 1)
2322 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Ambiguous line spec", -1);
2329 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
2334 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2335 Tcl_NewStringObj (sal
.symtab
->filename
, -1));
2337 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewStringObj ("", 0));
2339 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
2340 fname
= cplus_demangle (funcname
, 0);
2343 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2344 Tcl_NewStringObj (fname
, -1));
2348 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2349 Tcl_NewStringObj (funcname
, -1));
2351 filename
= symtab_to_filename (sal
.symtab
);
2352 if (filename
== NULL
)
2355 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2356 Tcl_NewStringObj (filename
, -1));
2357 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(sal
.line
)); /* line number */
2358 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
2359 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
2363 /* This implements the Tcl command 'gdb_get_mem', which
2364 * dumps a block of memory
2366 * gdb_get_mem addr form size num aschar
2368 * addr: address of data to dump
2369 * form: a char indicating format
2370 * size: size of each element; 1,2,4, or 8 bytes
2371 * num: the number of bytes to read
2372 * acshar: an optional ascii character to use in ASCII dump
2375 * a list of elements followed by an optional ASCII dump
2379 gdb_get_mem (clientData
, interp
, objc
, objv
)
2380 ClientData clientData
;
2383 Tcl_Obj
*CONST objv
[];
2385 int size
, asize
, i
, j
, bc
;
2387 int nbytes
, rnum
, bpr
;
2389 char format
, c
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
2390 struct type
*val_type
;
2392 if (objc
< 6 || objc
> 7)
2394 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2395 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2399 if (Tcl_GetIntFromObj (interp
, objv
[3], &size
) != TCL_OK
)
2401 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2406 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid size, must be > 0", -1);
2410 if (Tcl_GetIntFromObj (interp
, objv
[4], &nbytes
) != TCL_OK
)
2412 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2417 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid number of bytes, must be > 0",
2422 if (Tcl_GetIntFromObj (interp
, objv
[5], &bpr
) != TCL_OK
)
2424 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2429 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid bytes per row, must be > 0", -1);
2433 if (Tcl_GetLongFromObj (interp
, objv
[1], &tmp
) != TCL_OK
)
2436 addr
= (CORE_ADDR
) tmp
;
2438 format
= *(Tcl_GetStringFromObj (objv
[2], NULL
));
2439 mbuf
= (char *)malloc (nbytes
+32);
2442 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Out of memory.", -1);
2446 memset (mbuf
, 0, nbytes
+32);
2449 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
2452 aschar
= *(Tcl_GetStringFromObj(objv
[6], NULL
));
2458 val_type
= builtin_type_char
;
2462 val_type
= builtin_type_short
;
2466 val_type
= builtin_type_int
;
2470 val_type
= builtin_type_long_long
;
2474 val_type
= builtin_type_char
;
2478 bc
= 0; /* count of bytes in a row */
2479 buff
[0] = '"'; /* buffer for ascii dump */
2480 bptr
= &buff
[1]; /* pointer for ascii dump */
2482 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Build up the result as a list... */
2484 for (i
=0; i
< nbytes
; i
+= size
)
2488 fputs_unfiltered ("N/A ", gdb_stdout
);
2490 for ( j
= 0; j
< size
; j
++)
2495 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
2499 for ( j
= 0; j
< size
; j
++)
2502 if (c
< 32 || c
> 126)
2514 if (aschar
&& (bc
>= bpr
))
2516 /* end of row. print it and reset variables */
2521 fputs_unfiltered (buff
, gdb_stdout
);
2526 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
2534 /* This implements the tcl command "gdb_loadfile"
2535 * It loads a c source file into a text widget.
2538 * widget: the name of the text widget to fill
2539 * filename: the name of the file to load
2540 * linenumbers: A boolean indicating whether or not to display line numbers.
2545 /* In this routine, we will build up a "line table", i.e. a
2546 * table of bits showing which lines in the source file are executible.
2547 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2549 * Its size limits the maximum number of lines
2550 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2551 * the file is loaded, so it is OK to make this very large.
2552 * Additional memory will be allocated if needed. */
2553 #define LTABLE_SIZE 20000
2555 gdb_loadfile (clientData
, interp
, objc
, objv
)
2556 ClientData clientData
;
2559 Tcl_Obj
*CONST objv
[];
2561 char *file
, *widget
;
2562 int linenumbers
, ln
, lnum
, ltable_size
;
2565 struct symtab
*symtab
;
2566 struct linetable_entry
*le
;
2569 Tcl_DString text_cmd_1
, text_cmd_2
, *cur_cmd
;
2570 char line
[1024], line_num_buf
[16];
2571 int prefix_len_1
, prefix_len_2
, cur_prefix_len
, widget_len
;
2576 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
2580 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
2581 if ( Tk_NameToWindow (interp
, widget
, Tk_MainWindow (interp
)) == NULL
)
2586 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
2587 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
2589 symtab
= full_lookup_symtab (file
);
2592 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "File not found in symtab", -1);
2597 file
= symtab_to_filename ( symtab
);
2598 if ((fp
= fopen ( file
, "r" )) == NULL
)
2600 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Can't open file for reading", -1);
2604 if (stat (file
, &st
) < 0)
2606 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
2611 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
2612 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
2614 mtime
= bfd_get_mtime(exec_bfd
);
2616 if (mtime
&& mtime
< st
.st_mtime
)
2617 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2620 /* Source linenumbers don't appear to be in order, and a sort is */
2621 /* too slow so the fastest solution is just to allocate a huge */
2622 /* array and set the array entry for each linenumber */
2624 ltable_size
= LTABLE_SIZE
;
2625 ltable
= (char *)malloc (LTABLE_SIZE
);
2628 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2633 memset (ltable
, 0, LTABLE_SIZE
);
2635 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
2637 le
= symtab
->linetable
->item
;
2638 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
2640 lnum
= le
->line
>> 3;
2641 if (lnum
>= ltable_size
)
2644 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
2645 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
2647 if (new_ltable
== NULL
)
2649 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2654 ltable
= new_ltable
;
2656 ltable
[lnum
] |= 1 << (le
->line
% 8);
2660 Tcl_DStringInit(&text_cmd_1
);
2661 Tcl_DStringInit(&text_cmd_2
);
2665 widget_len
= strlen (widget
);
2668 Tcl_DStringAppend (&text_cmd_1
, widget
, widget_len
);
2669 Tcl_DStringAppend (&text_cmd_2
, widget
, widget_len
);
2673 Tcl_DStringAppend (&text_cmd_1
, " insert end {-\t", -1);
2674 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2676 Tcl_DStringAppend (&text_cmd_2
, " insert end { \t", -1);
2677 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2679 while (fgets (line
+ 1, 980, fp
))
2681 sprintf (line_num_buf
, "%d", ln
);
2682 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2684 cur_cmd
= &text_cmd_1
;
2685 cur_prefix_len
= prefix_len_1
;
2686 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2687 Tcl_DStringAppend (cur_cmd
, "} break_tag", 11);
2691 cur_cmd
= &text_cmd_2
;
2692 cur_prefix_len
= prefix_len_2
;
2693 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2694 Tcl_DStringAppend (cur_cmd
, "} \"\"", 4);
2697 Tcl_DStringAppendElement (cur_cmd
, line
);
2698 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2700 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2701 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2707 Tcl_DStringAppend (&text_cmd_1
, " insert end {- } break_tag", -1);
2708 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2709 Tcl_DStringAppend (&text_cmd_2
, " insert end { } \"\"", -1);
2710 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2712 while (fgets (line
+ 1, 980, fp
))
2714 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2716 cur_cmd
= &text_cmd_1
;
2717 cur_prefix_len
= prefix_len_1
;
2721 cur_cmd
= &text_cmd_2
;
2722 cur_prefix_len
= prefix_len_2
;
2725 Tcl_DStringAppendElement (cur_cmd
, line
);
2726 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2728 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2729 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2735 Tcl_DStringFree (&text_cmd_1
);
2736 Tcl_DStringFree (&text_cmd_2
);
2743 * This section contains commands for manipulation of breakpoints.
2747 /* set a breakpoint by source file and line number */
2748 /* flags are as follows: */
2749 /* least significant 2 bits are disposition, rest is */
2750 /* type (normally 0).
2753 bp_breakpoint, Normal breakpoint
2754 bp_hardware_breakpoint, Hardware assisted breakpoint
2757 Disposition of breakpoint. Ie: what to do after hitting it.
2760 del_at_next_stop, Delete at next stop, whether hit or not
2762 donttouch Leave it alone
2766 /* This implements the tcl command "gdb_set_bp"
2767 * It sets breakpoints, and runs the Tcl command
2768 * gdbtk_tcl_breakpoint create
2769 * to register the new breakpoint with the GUI.
2772 * filename: the file in which to set the breakpoint
2773 * line: the line number for the breakpoint
2774 * type: the type of the breakpoint
2776 * The return value of the call to gdbtk_tcl_breakpoint.
2780 gdb_set_bp (clientData
, interp
, objc
, objv
)
2781 ClientData clientData
;
2784 Tcl_Obj
*CONST objv
[];
2787 struct symtab_and_line sal
;
2788 int line
, flags
, ret
;
2789 struct breakpoint
*b
;
2795 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
2799 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
2800 if (sal
.symtab
== NULL
)
2803 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
2805 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2809 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
2811 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2816 if (!find_line_pc (sal
.symtab
, sal
.line
, &sal
.pc
))
2819 sal
.section
= find_pc_overlay (sal
.pc
);
2820 b
= set_raw_breakpoint (sal
);
2821 set_breakpoint_count (breakpoint_count
+ 1);
2822 b
->number
= breakpoint_count
;
2823 b
->type
= flags
>> 2;
2824 b
->disposition
= flags
& 3;
2826 /* FIXME: this won't work for duplicate basenames! */
2827 sprintf (buf
, "%s:%d", basename (Tcl_GetStringFromObj ( objv
[1], NULL
)), line
);
2828 b
->addr_string
= strsave (buf
);
2830 /* now send notification command back to GUI */
2832 Tcl_DStringInit (&cmd
);
2834 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2835 sprintf (buf
, "%d", b
->number
);
2836 Tcl_DStringAppendElement(&cmd
, buf
);
2837 sprintf (buf
, "0x%lx", (long)sal
.pc
);
2838 Tcl_DStringAppendElement (&cmd
, buf
);
2839 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[2], NULL
));
2840 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[1], NULL
));
2842 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2843 Tcl_DStringFree (&cmd
);
2847 /* This implements the tcl command gdb_get_breakpoint_info
2853 * A list with {file, function, line_number, address, type, enabled?,
2854 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
2858 gdb_get_breakpoint_info (clientData
, interp
, objc
, objv
)
2859 ClientData clientData
;
2862 Tcl_Obj
*CONST objv
[];
2864 struct symtab_and_line sal
;
2865 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
2866 "finish", "watchpoint", "hardware watchpoint",
2867 "read watchpoint", "access watchpoint",
2868 "longjmp", "longjmp resume", "step resume",
2869 "through sigtramp", "watchpoint scope",
2871 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
2872 struct command_line
*cmd
;
2874 struct breakpoint
*b
;
2875 extern struct breakpoint
*breakpoint_chain
;
2876 char *funcname
, *fname
, *filename
;
2881 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong number of args, should be \"breakpoint\"", -1);
2885 if ( Tcl_GetIntFromObj(NULL
, objv
[1], &bpnum
) != TCL_OK
)
2887 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2891 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2892 if (b
->number
== bpnum
)
2895 if (!b
|| b
->type
!= bp_breakpoint
)
2897 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Breakpoint #%d does not exist", -1);
2901 sal
= find_pc_line (b
->address
, 0);
2903 filename
= symtab_to_filename (sal
.symtab
);
2904 if (filename
== NULL
)
2907 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
2908 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2909 Tcl_NewStringObj (filename
, -1));
2911 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
2912 fname
= cplus_demangle (funcname
, 0);
2915 new_obj
= Tcl_NewStringObj (fname
, -1);
2919 new_obj
= Tcl_NewStringObj (funcname
, -1);
2921 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2923 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->line_number
));
2924 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%lx", b
->address
);
2925 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2926 Tcl_NewStringObj (bptypes
[b
->type
], -1));
2927 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewBooleanObj(b
->enable
== enabled
));
2928 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2929 Tcl_NewStringObj (bpdisp
[b
->disposition
], -1));
2930 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->ignore_count
));
2932 new_obj
= Tcl_NewObj();
2933 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
2934 Tcl_ListObjAppendElement (NULL
, new_obj
,
2935 Tcl_NewStringObj (cmd
->line
, -1));
2936 Tcl_ListObjAppendElement(NULL
, result_ptr
->obj_ptr
, new_obj
);
2938 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2939 Tcl_NewStringObj (b
->cond_string
, -1));
2941 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->thread
));
2942 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->hit_count
));
2948 /* This implements the tcl command gdb_get_breakpoint_list
2949 * It builds up a list of the current breakpoints.
2954 * A list of breakpoint numbers.
2958 gdb_get_breakpoint_list (clientData
, interp
, objc
, objv
)
2959 ClientData clientData
;
2962 Tcl_Obj
*CONST objv
[];
2964 struct breakpoint
*b
;
2965 extern struct breakpoint
*breakpoint_chain
;
2969 error ("wrong number of args, none are allowed");
2971 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2972 if (b
->type
== bp_breakpoint
)
2974 new_obj
= Tcl_NewIntObj (b
->number
);
2975 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2981 /* The functions in this section deal with stacks and backtraces. */
2983 /* This implements the tcl command gdb_stack.
2984 * It builds up a list of stack frames.
2987 * start - starting stack frame
2988 * count - number of frames to inspect
2990 * A list of function names
2994 gdb_stack (clientData
, interp
, objc
, objv
) ClientData clientData
;
2997 Tcl_Obj
*CONST objv
[];
3003 Tcl_WrongNumArgs (interp
, 1, objv
, "start count");
3004 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3008 if (Tcl_GetIntFromObj (NULL
, objv
[1], &start
))
3010 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3013 if (Tcl_GetIntFromObj (NULL
, objv
[2], &count
))
3015 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3019 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
3021 if (target_has_stack
)
3023 struct frame_info
*top
;
3024 struct frame_info
*fi
;
3026 /* Find the outermost frame */
3027 fi
= get_current_frame ();
3031 fi
= get_prev_frame (fi
);
3034 /* top now points to the top (outermost frame) of the
3035 stack, so point it to the requested start */
3037 top
= find_relative_frame (top
, &start
);
3039 /* If start != 0, then we have asked to start outputting
3040 frames beyond the innermost stack frame */
3044 while (fi
&& count
--)
3046 get_frame_name (interp
, result_ptr
->obj_ptr
, fi
);
3047 fi
= get_next_frame (fi
);
3055 /* A helper function for get_stack which adds information about
3056 * the stack frame FI to the caller's LIST.
3058 * This is stolen from print_frame_info in stack.c.
3061 get_frame_name (interp
, list
, fi
)
3064 struct frame_info
*fi
;
3066 struct symtab_and_line sal
;
3067 struct symbol
*func
= NULL
;
3068 register char *funname
= 0;
3069 enum language funlang
= language_unknown
;
3072 if (frame_in_dummy (fi
))
3074 objv
[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
3075 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3078 if (fi
->signal_handler_caller
)
3080 objv
[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
3081 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3086 find_pc_line (fi
->pc
,
3088 && !fi
->next
->signal_handler_caller
3089 && !frame_in_dummy (fi
->next
));
3091 func
= find_pc_function (fi
->pc
);
3094 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3096 && (SYMBOL_VALUE_ADDRESS (msymbol
)
3097 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
3100 funname
= SYMBOL_NAME (msymbol
);
3101 funlang
= SYMBOL_LANGUAGE (msymbol
);
3105 funname
= SYMBOL_NAME (func
);
3106 funlang
= SYMBOL_LANGUAGE (func
);
3111 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3112 if (msymbol
!= NULL
)
3114 funname
= SYMBOL_NAME (msymbol
);
3115 funlang
= SYMBOL_LANGUAGE (msymbol
);
3123 if (funlang
== language_cplus
)
3124 name
= cplus_demangle (funname
, 0);
3128 objv
[0] = Tcl_NewStringObj (name
, -1);
3129 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3134 /* we have no convenient way to deal with this yet... */
3135 if (fi
->pc
!= sal
.pc
|| !sal
.symtab
)
3137 print_address_numeric (fi
->pc
, 1, gdb_stdout
);
3138 printf_filtered (" in ");
3140 printf_symbol_filtered (gdb_stdout
, funname
? funname
: "??", funlang
,
3143 objv
[0] = Tcl_NewStringObj (funname
!= NULL
? funname
: "??", -1);
3144 #ifdef PC_LOAD_SEGMENT
3145 /* If we couldn't print out function name but if can figure out what
3146 load segment this pc value is from, at least print out some info
3147 about its load segment. */
3150 Tcl_AppendStringsToObj (objv
[0], " from ", PC_LOAD_SEGMENT (fi
->pc
),
3157 char *lib
= PC_SOLIB (fi
->pc
);
3160 Tcl_AppendStringsToObj (objv
[0], " from ", lib
, (char *) NULL
);
3164 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3170 * This section contains a bunch of miscellaneous utility commands
3173 /* This implements the tcl command gdb_path_conv
3175 * On Windows, it canonicalizes the pathname,
3176 * On Unix, it is a no op.
3181 * The canonicalized path.
3185 gdb_path_conv (clientData
, interp
, objc
, objv
)
3186 ClientData clientData
;
3189 Tcl_Obj
*CONST objv
[];
3192 error ("wrong # args");
3196 char pathname
[256], *ptr
;
3198 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj(objv
[1], NULL
), pathname
);
3199 for (ptr
= pathname
; *ptr
; ptr
++)
3204 Tcl_SetStringObj (result_ptr
->obj_ptr
, pathname
, -1);
3207 Tcl_SetStringObj (result_ptr
->obj_ptr
, Tcl_GetStringFromObj (objv
[1], NULL
), -1);
3214 * This section has utility routines that are not Tcl commands.
3218 perror_with_name_wrapper (args
)
3221 perror_with_name (args
);
3225 /* The lookup_symtab() in symtab.c doesn't work correctly */
3226 /* It will not work will full pathnames and if multiple */
3227 /* source files have the same basename, it will return */
3228 /* the first one instead of the correct one. This version */
3229 /* also always makes sure symtab->fullname is set. */
3231 static struct symtab
*
3232 full_lookup_symtab(file
)
3236 struct objfile
*objfile
;
3237 char *bfile
, *fullname
;
3238 struct partial_symtab
*pt
;
3243 /* first try a direct lookup */
3244 st
= lookup_symtab (file
);
3248 symtab_to_filename(st
);
3252 /* if the direct approach failed, try */
3253 /* looking up the basename and checking */
3254 /* all matches with the fullname */
3255 bfile
= basename (file
);
3256 ALL_SYMTABS (objfile
, st
)
3258 if (!strcmp (bfile
, basename(st
->filename
)))
3261 fullname
= symtab_to_filename (st
);
3263 fullname
= st
->fullname
;
3265 if (!strcmp (file
, fullname
))
3270 /* still no luck? look at psymtabs */
3271 ALL_PSYMTABS (objfile
, pt
)
3273 if (!strcmp (bfile
, basename(pt
->filename
)))
3275 st
= PSYMTAB_TO_SYMTAB (pt
);
3278 fullname
= symtab_to_filename (st
);
3279 if (!strcmp (file
, fullname
))