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
[];
568 if (target_stop
!= target_ignore
)
571 quit_flag
= 1; /* hope something sees this */
578 * This section contains Tcl commands that are wrappers for invoking
579 * the GDB command interpreter.
583 /* This implements the tcl command `gdb_eval'.
584 * It uses the gdb evaluator to return the value of
585 * an expression in the current language
588 * expression - the expression to evaluate.
590 * The result of the evaluation.
594 gdb_eval (clientData
, interp
, objc
, objv
)
595 ClientData clientData
;
598 Tcl_Obj
*CONST objv
[];
600 struct expression
*expr
;
601 struct cleanup
*old_chain
=NULL
;
606 Tcl_SetStringObj (result_ptr
->obj_ptr
,
607 "wrong # args, should be \"gdb_eval expression\"", -1);
611 expr
= parse_expression (Tcl_GetStringFromObj (objv
[1], NULL
));
613 old_chain
= make_cleanup (free_current_contents
, &expr
);
615 val
= evaluate_expression (expr
);
618 * Print the result of the expression evaluation. This will go to
619 * eventually go to gdbtk_fputs, and from there be collected into
623 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
624 gdb_stdout
, 0, 0, 0, 0);
626 do_cleanups (old_chain
);
631 /* This implements the tcl command "gdb_cmd".
633 * It sends its argument to the GDB command scanner for execution.
634 * This command will never cause the update, idle and busy hooks to be called
638 * command - The GDB command to execute
640 * The output from the gdb command (except for the "load" & "while"
641 * which dump their output to the console.
645 gdb_cmd (clientData
, interp
, objc
, objv
)
646 ClientData clientData
;
649 Tcl_Obj
*CONST objv
[];
654 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
658 if (running_now
|| load_in_progress
)
663 /* for the load instruction (and possibly others later) we
664 set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
665 will not buffer all the data until the command is finished. */
667 if ((strncmp ("load ", Tcl_GetStringFromObj (objv
[1], NULL
), 5) == 0))
669 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
670 load_in_progress
= 1;
673 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
675 if (load_in_progress
)
677 load_in_progress
= 0;
678 result_ptr
->flags
|= GDBTK_TO_RESULT
;
681 bpstat_do_actions (&stop_bpstat
);
687 * This implements the tcl command "gdb_immediate"
689 * It does exactly the same thing as gdb_cmd, except NONE of its outut
690 * is buffered. This will also ALWAYS cause the busy, update, and idle hooks to
691 * be called, contrasted with gdb_cmd, which NEVER calls them.
692 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
693 * to the console window.
696 * command - The GDB command to execute
702 gdb_immediate_command (clientData
, interp
, objc
, objv
)
703 ClientData clientData
;
706 Tcl_Obj
*CONST objv
[];
711 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
715 if (running_now
|| load_in_progress
)
720 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
722 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
724 bpstat_do_actions (&stop_bpstat
);
726 result_ptr
->flags
|= GDBTK_TO_RESULT
;
731 /* This implements the tcl command "gdb_prompt"
733 * It returns the gdb interpreter's prompt.
742 gdb_prompt_command (clientData
, interp
, objc
, objv
)
743 ClientData clientData
;
746 Tcl_Obj
*CONST objv
[];
748 Tcl_SetStringObj (result_ptr
->obj_ptr
, get_prompt (), -1);
754 * This section contains general informational commands.
757 /* This implements the tcl command "gdb_target_has_execution"
759 * Tells whether the target is executing.
764 * A boolean indicating whether the target is executing.
768 gdb_target_has_execution_command (clientData
, interp
, objc
, objv
)
769 ClientData clientData
;
772 Tcl_Obj
*CONST objv
[];
776 if (target_has_execution
&& inferior_pid
!= 0)
779 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, result
);
783 /* This implements the tcl command "gdb_load_info"
785 * It returns information about the file about to be downloaded.
788 * filename: The file to open & get the info on.
790 * A list consisting of the name and size of each section.
794 gdb_load_info (clientData
, interp
, objc
, objv
)
795 ClientData clientData
;
798 Tcl_Obj
*CONST objv
[];
801 struct cleanup
*old_cleanups
;
805 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
807 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
808 if (loadfile_bfd
== NULL
)
810 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Open failed", -1);
813 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
815 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
817 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Bad Object File", -1);
821 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
823 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
825 if (s
->flags
& SEC_LOAD
)
827 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
830 ob
[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd
, s
), -1);
831 ob
[1] = Tcl_NewLongObj ((long) size
);
832 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewListObj (2, ob
));
837 do_cleanups (old_cleanups
);
843 * This and gdb_get_locals just call gdb_get_vars_command with the right
844 * value of clientData. We can't use the client data in the definition
845 * of the command, because the call wrapper uses this instead...
849 gdb_get_locals_command (clientData
, interp
, objc
, objv
)
850 ClientData clientData
;
853 Tcl_Obj
*CONST objv
[];
856 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
861 gdb_get_args_command (clientData
, interp
, objc
, objv
)
862 ClientData clientData
;
865 Tcl_Obj
*CONST objv
[];
868 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
872 /* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
874 * This function sets the Tcl interpreter's result to a list of variable names
875 * depending on clientData. If clientData is one, the result is a list of
876 * arguments; zero returns a list of locals -- all relative to the block
877 * specified as an argument to the command. Valid commands include
878 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
882 * block - the address within which to specify the locals or args.
884 * A list of the locals or args
888 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
889 ClientData clientData
;
892 Tcl_Obj
*CONST objv
[];
894 struct symtabs_and_lines sals
;
897 char **canonical
, *args
;
898 int i
, nsyms
, arguments
;
902 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
,
903 "wrong # of args: should be \"",
904 Tcl_GetStringFromObj (objv
[0], NULL
),
905 " function:line|function|line|*addr\"", NULL
);
909 arguments
= (int) clientData
;
910 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
911 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
914 Tcl_SetStringObj (result_ptr
->obj_ptr
,
915 "error decoding line", -1);
919 /* Initialize the result pointer to an empty list. */
921 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
923 /* Resolve all line numbers to PC's */
924 for (i
= 0; i
< sals
.nelts
; i
++)
925 resolve_sal_pc (&sals
.sals
[i
]);
927 block
= block_for_pc (sals
.sals
[0].pc
);
930 nsyms
= BLOCK_NSYMS (block
);
931 for (i
= 0; i
< nsyms
; i
++)
933 sym
= BLOCK_SYM (block
, i
);
934 switch (SYMBOL_CLASS (sym
)) {
936 case LOC_UNDEF
: /* catches errors */
937 case LOC_CONST
: /* constant */
938 case LOC_TYPEDEF
: /* local typedef */
939 case LOC_LABEL
: /* local label */
940 case LOC_BLOCK
: /* local function */
941 case LOC_CONST_BYTES
: /* loc. byte seq. */
942 case LOC_UNRESOLVED
: /* unresolved static */
943 case LOC_OPTIMIZED_OUT
: /* optimized out */
945 case LOC_ARG
: /* argument */
946 case LOC_REF_ARG
: /* reference arg */
947 case LOC_REGPARM
: /* register arg */
948 case LOC_REGPARM_ADDR
: /* indirect register arg */
949 case LOC_LOCAL_ARG
: /* stack arg */
950 case LOC_BASEREG_ARG
: /* basereg arg */
952 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
953 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
955 case LOC_LOCAL
: /* stack local */
956 case LOC_BASEREG
: /* basereg local */
957 case LOC_STATIC
: /* static */
958 case LOC_REGISTER
: /* register */
960 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
961 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
965 if (BLOCK_FUNCTION (block
))
968 block
= BLOCK_SUPERBLOCK (block
);
974 /* This implements the tcl command "gdb_get_line"
976 * It returns the linenumber for a given linespec. It will take any spec
977 * that can be passed to decode_line_1
980 * linespec - the line specification
982 * The line number for that spec.
985 gdb_get_line_command (clientData
, interp
, objc
, objv
)
986 ClientData clientData
;
989 Tcl_Obj
*CONST objv
[];
991 struct symtabs_and_lines sals
;
992 char *args
, **canonical
;
996 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
997 Tcl_GetStringFromObj (objv
[0], NULL
),
998 " linespec\"", NULL
);
1002 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1003 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1004 if (sals
.nelts
== 1)
1006 Tcl_SetIntObj (result_ptr
->obj_ptr
, sals
.sals
[0].line
);
1010 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1015 /* This implements the tcl command "gdb_get_file"
1017 * It returns the file containing a given line spec.
1020 * linespec - The linespec to look up
1022 * The file containing it.
1026 gdb_get_file_command (clientData
, interp
, objc
, objv
)
1027 ClientData clientData
;
1030 Tcl_Obj
*CONST objv
[];
1032 struct symtabs_and_lines sals
;
1033 char *args
, **canonical
;
1037 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1038 Tcl_GetStringFromObj (objv
[0], NULL
),
1039 " linespec\"", NULL
);
1043 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1044 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1045 if (sals
.nelts
== 1)
1047 Tcl_SetStringObj (result_ptr
->obj_ptr
, sals
.sals
[0].symtab
->filename
, -1);
1051 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1055 /* This implements the tcl command "gdb_get_function"
1057 * It finds the function containing the given line spec.
1060 * linespec - The line specification
1062 * The function that contains it, or "N/A" if it is not in a function.
1065 gdb_get_function_command (clientData
, interp
, objc
, objv
)
1066 ClientData clientData
;
1069 Tcl_Obj
*CONST objv
[];
1072 struct symtabs_and_lines sals
;
1073 char *args
, **canonical
;
1077 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1078 Tcl_GetStringFromObj (objv
[0], NULL
),
1079 " linespec\"", NULL
);
1083 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1084 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1085 if (sals
.nelts
== 1)
1087 resolve_sal_pc (&sals
.sals
[0]);
1088 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
1089 if (function
!= NULL
)
1091 Tcl_SetStringObj (result_ptr
->obj_ptr
, function
, -1);
1096 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1100 /* This implements the tcl command "gdb_find_file"
1102 * It searches the symbol tables to get the full pathname to a file.
1105 * filename: the file name to search for.
1107 * The full path to the file, or an empty string if the file is not
1112 gdb_find_file_command (clientData
, interp
, objc
, objv
)
1113 ClientData clientData
;
1116 Tcl_Obj
*CONST objv
[];
1118 char *filename
= NULL
;
1123 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
1127 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1129 filename
= st
->fullname
;
1131 if (filename
== NULL
)
1132 Tcl_SetStringObj (result_ptr
->obj_ptr
, "", 0);
1134 Tcl_SetStringObj (result_ptr
->obj_ptr
, filename
, -1);
1139 /* This implements the tcl command "gdb_listfiles"
1141 * This lists all the files in the current executible.
1143 * Note that this currently pulls in all sorts of filenames
1144 * that aren't really part of the executable. It would be
1145 * best if we could check each file to see if it actually
1146 * contains executable lines of code, but we can't do that
1150 * ?pathname? - If provided, only files which match pathname
1151 * (up to strlen(pathname)) are included. THIS DOES NOT
1152 * CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1153 * THE FULL PATHNAME!!!
1156 * A list of all matching files.
1159 gdb_listfiles (clientData
, interp
, objc
, objv
)
1160 ClientData clientData
;
1163 Tcl_Obj
*CONST objv
[];
1165 struct objfile
*objfile
;
1166 struct partial_symtab
*psymtab
;
1167 struct symtab
*symtab
;
1168 char *lastfile
, *pathname
=NULL
, **files
;
1170 int i
, numfiles
= 0, len
= 0;
1173 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1177 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1181 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1183 ALL_PSYMTABS (objfile
, psymtab
)
1185 if (numfiles
== files_size
)
1187 files_size
= files_size
* 2;
1188 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1190 if (psymtab
->filename
)
1192 if (!len
|| !strncmp(pathname
, psymtab
->filename
,len
)
1193 || !strcmp(psymtab
->filename
, basename(psymtab
->filename
)))
1195 files
[numfiles
++] = basename(psymtab
->filename
);
1200 ALL_SYMTABS (objfile
, symtab
)
1202 if (numfiles
== files_size
)
1204 files_size
= files_size
* 2;
1205 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1207 if (symtab
->filename
&& symtab
->linetable
&& symtab
->linetable
->nitems
)
1209 if (!len
|| !strncmp(pathname
, symtab
->filename
,len
)
1210 || !strcmp(symtab
->filename
, basename(symtab
->filename
)))
1212 files
[numfiles
++] = basename(symtab
->filename
);
1217 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1221 /* Discard the old result pointer, in case it has accumulated anything
1222 and set it to a new list object */
1224 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1226 for (i
= 0; i
< numfiles
; i
++)
1228 if (strcmp(files
[i
],lastfile
))
1229 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj(files
[i
], -1));
1230 lastfile
= files
[i
];
1238 comp_files (file1
, file2
)
1239 const void *file1
, *file2
;
1241 return strcmp(* (char **) file1
, * (char **) file2
);
1245 /* This implements the tcl command "gdb_search"
1249 * option - One of "functions", "variables" or "types"
1250 * regexp - The regular expression to look for.
1259 gdb_search (clientData
, interp
, objc
, objv
)
1260 ClientData clientData
;
1263 Tcl_Obj
*CONST objv
[];
1265 struct symbol_search
*ss
= NULL
;
1266 struct symbol_search
*p
;
1267 struct cleanup
*old_chain
= NULL
;
1268 Tcl_Obj
*CONST
*switch_objv
;
1269 int index
, switch_objc
, i
;
1270 namespace_enum space
= 0;
1272 int static_only
, nfiles
;
1273 Tcl_Obj
**file_list
;
1275 static char *search_options
[] = { "functions", "variables", "types", (char *) NULL
};
1276 static char *switches
[] = { "-files", "-static", (char *) NULL
};
1277 enum search_opts
{ SEARCH_FUNCTIONS
, SEARCH_VARIABLES
, SEARCH_TYPES
};
1278 enum switches_opts
{ SWITCH_FILES
, SWITCH_STATIC_ONLY
};
1282 Tcl_WrongNumArgs (interp
, 1, objv
, "option regexp ?arg ...?");
1283 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1287 if (Tcl_GetIndexFromObj (interp
, objv
[1], search_options
, "option", 0,
1290 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1294 /* Unfortunately, we cannot teach search_symbols to search on
1295 multiple regexps, so we have to do a two-tier search for
1296 any searches which choose to narrow the playing field. */
1297 switch ((enum search_opts
) index
)
1299 case SEARCH_FUNCTIONS
:
1300 space
= FUNCTIONS_NAMESPACE
; break;
1301 case SEARCH_VARIABLES
:
1302 space
= VARIABLES_NAMESPACE
; break;
1304 space
= TYPES_NAMESPACE
; break;
1307 regexp
= Tcl_GetStringFromObj (objv
[2], NULL
);
1308 /* Process any switches that refine the search */
1309 switch_objc
= objc
- 3;
1310 switch_objv
= objv
+ 3;
1314 files
= (char **) NULL
;
1315 while (switch_objc
> 0)
1317 if (Tcl_GetIndexFromObj (interp
, switch_objv
[0], switches
,
1318 "option", 0, &index
) != TCL_OK
)
1320 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1324 switch ((enum switches_opts
) index
)
1329 if (switch_objc
< 2)
1331 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList -static 1|0]");
1332 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1335 result
= Tcl_ListObjGetElements (interp
, switch_objv
[1], &nfiles
, &file_list
);
1336 if (result
!= TCL_OK
)
1339 files
= (char **) xmalloc (nfiles
* sizeof (char *));
1340 for (i
= 0; i
< nfiles
; i
++)
1341 files
[i
] = Tcl_GetStringFromObj (file_list
[i
], NULL
);
1346 case SWITCH_STATIC_ONLY
:
1347 if (switch_objc
< 2)
1349 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList] [-static 1|0]");
1350 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1353 if ( Tcl_GetBooleanFromObj (interp
, switch_objv
[1], &static_only
) !=
1355 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1365 search_symbols (regexp
, space
, nfiles
, files
, &ss
);
1367 old_chain
= make_cleanup (free_search_symbols
, ss
);
1369 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1371 for (p
= ss
; p
!= NULL
; p
= p
->next
)
1375 if (static_only
&& p
->block
!= STATIC_BLOCK
)
1378 elem
= Tcl_NewListObj (0, NULL
);
1380 if (p
->msymbol
== NULL
)
1381 Tcl_ListObjAppendElement (interp
, elem
,
1382 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->symbol
), -1));
1384 Tcl_ListObjAppendElement (interp
, elem
,
1385 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->msymbol
), -1));
1387 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, elem
);
1391 do_cleanups (old_chain
);
1396 /* This implements the tcl command gdb_listfuncs
1398 * It lists all the functions defined in a given file
1401 * file - the file to look in
1403 * A list of two element lists, the first element is
1404 * the symbol name, and the second is a boolean indicating
1405 * whether the symbol is demangled (1 for yes).
1409 gdb_listfuncs (clientData
, interp
, objc
, objv
)
1410 ClientData clientData
;
1413 Tcl_Obj
*CONST objv
[];
1415 struct symtab
*symtab
;
1416 struct blockvector
*bv
;
1420 Tcl_Obj
*funcVals
[2];
1424 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1427 symtab
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1430 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No such file", -1);
1434 if (mangled
== NULL
)
1436 mangled
= Tcl_NewBooleanObj(1);
1437 not_mangled
= Tcl_NewBooleanObj(0);
1438 Tcl_IncrRefCount(mangled
);
1439 Tcl_IncrRefCount(not_mangled
);
1442 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1444 bv
= BLOCKVECTOR (symtab
);
1445 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1447 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1448 /* Skip the sort if this block is always sorted. */
1449 if (!BLOCK_SHOULD_SORT (b
))
1450 sort_block_syms (b
);
1451 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1453 sym
= BLOCK_SYM (b
, j
);
1454 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1457 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1460 /* strip out "global constructors" and "global destructors" */
1461 /* because we aren't interested in them. */
1462 if (strncmp (name
, "global ", 7))
1464 funcVals
[0] = Tcl_NewStringObj(name
, -1);
1465 funcVals
[1] = mangled
;
1473 funcVals
[0] = Tcl_NewStringObj(SYMBOL_NAME(sym
), -1);
1474 funcVals
[1] = not_mangled
;
1476 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1477 Tcl_NewListObj (2, funcVals
));
1486 * This section contains all the commands that act on the registers:
1489 /* This is a sort of mapcar function for operations on registers */
1492 map_arg_registers (objc
, objv
, func
, argp
)
1494 Tcl_Obj
*CONST objv
[];
1495 void (*func
) PARAMS ((int regnum
, void *argp
));
1500 /* Note that the test for a valid register must include checking the
1501 reg_names array because NUM_REGS may be allocated for the union of the
1502 register sets within a family of related processors. In this case, the
1503 trailing entries of reg_names will change depending upon the particular
1504 processor being debugged. */
1506 if (objc
== 0) /* No args, just do all the regs */
1510 && reg_names
[regnum
] != NULL
1511 && *reg_names
[regnum
] != '\000';
1513 func (regnum
, argp
);
1518 /* Else, list of register #s, just do listed regs */
1519 for (; objc
> 0; objc
--, objv
++)
1521 if (Tcl_GetIntFromObj (NULL
, *objv
, ®num
) != TCL_OK
)
1523 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1528 && regnum
< NUM_REGS
1529 && reg_names
[regnum
] != NULL
1530 && *reg_names
[regnum
] != '\000')
1531 func (regnum
, argp
);
1534 Tcl_SetStringObj (result_ptr
->obj_ptr
, "bad register number", -1);
1542 /* This implements the TCL command `gdb_regnames', which returns a list of
1543 all of the register names. */
1546 gdb_regnames (clientData
, interp
, objc
, objv
)
1547 ClientData clientData
;
1550 Tcl_Obj
*CONST objv
[];
1555 return map_arg_registers (objc
, objv
, get_register_name
, NULL
);
1559 get_register_name (regnum
, argp
)
1561 void *argp
; /* Ignored */
1563 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1564 Tcl_NewStringObj (reg_names
[regnum
], -1));
1567 /* This implements the tcl command gdb_fetch_registers
1568 * Pass it a list of register names, and it will
1569 * return their values as a list.
1572 * format: The format string for printing the values
1573 * args: the registers to look for
1575 * A list of their values.
1579 gdb_fetch_registers (clientData
, interp
, objc
, objv
)
1580 ClientData clientData
;
1583 Tcl_Obj
*CONST objv
[];
1589 Tcl_SetStringObj (result_ptr
->obj_ptr
,
1590 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
1594 format
= *(Tcl_GetStringFromObj(objv
[0], NULL
));
1598 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Output the results as a list */
1599 result
= map_arg_registers (objc
, objv
, get_register
, (void *) format
);
1600 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
1606 get_register (regnum
, fp
)
1610 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1611 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
1612 int format
= (int)fp
;
1617 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1619 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1620 Tcl_NewStringObj ("Optimized out", -1));
1624 /* Convert raw data to virtual format if necessary. */
1626 if (REGISTER_CONVERTIBLE (regnum
))
1628 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
1629 raw_buffer
, virtual_buffer
);
1632 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1637 printf_filtered ("0x");
1638 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1640 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1641 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1642 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
1646 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
1647 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1651 /* This implements the tcl command get_pc_reg
1652 * It returns the value of the PC register
1657 * The value of the pc register.
1661 get_pc_register (clientData
, interp
, objc
, objv
)
1662 ClientData clientData
;
1665 Tcl_Obj
*CONST objv
[];
1669 sprintf (buff
, "0x%llx",(long long) read_register (PC_REGNUM
));
1670 Tcl_SetStringObj(result_ptr
->obj_ptr
, buff
, -1);
1674 /* This implements the tcl command "gdb_changed_register_list"
1675 * It takes a list of registers, and returns a list of
1676 * the registers on that list that have changed since the last
1677 * time the proc was called.
1680 * A list of registers.
1682 * A list of changed registers.
1686 gdb_changed_register_list (clientData
, interp
, objc
, objv
)
1687 ClientData clientData
;
1690 Tcl_Obj
*CONST objv
[];
1695 return map_arg_registers (objc
, objv
, register_changed_p
, NULL
);
1699 register_changed_p (regnum
, argp
)
1701 void *argp
; /* Ignored */
1703 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1705 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1708 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1709 REGISTER_RAW_SIZE (regnum
)) == 0)
1712 /* Found a changed register. Save new value and return its number. */
1714 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1715 REGISTER_RAW_SIZE (regnum
));
1717 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(regnum
));
1721 * This section contains the commands that deal with tracepoints:
1724 /* return a list of all tracepoint numbers in interpreter */
1726 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
1727 ClientData clientData
;
1730 Tcl_Obj
*CONST objv
[];
1732 struct tracepoint
*tp
;
1734 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1736 ALL_TRACEPOINTS (tp
)
1737 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->number
));
1742 /* returns -1 if not found, tracepoint # if found */
1744 tracepoint_exists (char * args
)
1746 struct tracepoint
*tp
;
1748 struct symtabs_and_lines sals
;
1752 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1753 if (sals
.nelts
== 1)
1755 resolve_sal_pc (&sals
.sals
[0]);
1756 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
1757 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
1760 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
1761 strcat (file
, sals
.sals
[0].symtab
->filename
);
1763 ALL_TRACEPOINTS (tp
)
1765 if (tp
->address
== sals
.sals
[0].pc
)
1766 result
= tp
->number
;
1768 /* Why is this here? This messes up assembly traces */
1769 else if (tp
->source_file
!= NULL
1770 && strcmp (tp
->source_file
, file
) == 0
1771 && sals
.sals
[0].line
== tp
->line_number
)
1772 result
= tp
->number
;
1783 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
1784 ClientData clientData
;
1787 Tcl_Obj
*CONST objv
[];
1793 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1794 Tcl_GetStringFromObj (objv
[0], NULL
),
1795 " function:line|function|line|*addr\"", NULL
);
1799 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1801 Tcl_SetIntObj (result_ptr
->obj_ptr
, tracepoint_exists (args
));
1806 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
1807 ClientData clientData
;
1810 Tcl_Obj
*CONST objv
[];
1812 struct symtab_and_line sal
;
1814 struct tracepoint
*tp
;
1815 struct action_line
*al
;
1816 Tcl_Obj
*action_list
;
1817 char *filename
, *funcname
;
1822 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1826 if (Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
) != TCL_OK
)
1828 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1832 ALL_TRACEPOINTS (tp
)
1833 if (tp
->number
== tpnum
)
1838 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Tracepoint #%d does not exist", -1);
1842 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1843 sal
= find_pc_line (tp
->address
, 0);
1844 filename
= symtab_to_filename (sal
.symtab
);
1845 if (filename
== NULL
)
1847 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1848 Tcl_NewStringObj (filename
, -1));
1849 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
1850 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (funcname
, -1));
1851 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (sal
.line
));
1852 sprintf (tmp
, "0x%lx", tp
->address
);
1853 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (tmp
, -1));
1854 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->enabled
));
1855 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->pass_count
));
1856 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->step_count
));
1857 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->thread
));
1858 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->hit_count
));
1860 /* Append a list of actions */
1861 action_list
= Tcl_NewObj ();
1862 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
1864 Tcl_ListObjAppendElement (interp
, action_list
,
1865 Tcl_NewStringObj (al
->action
, -1));
1867 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, action_list
);
1874 gdb_trace_status (clientData
, interp
, objc
, objv
)
1875 ClientData clientData
;
1878 Tcl_Obj
*CONST objv
[];
1882 if (trace_running_p
)
1885 Tcl_SetIntObj (result_ptr
->obj_ptr
, result
);
1892 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
1893 ClientData clientData
;
1896 Tcl_Obj
*CONST objv
[];
1900 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1901 Tcl_GetStringFromObj (objv
[0], NULL
),
1902 " linespec\"", NULL
);
1906 Tcl_SetIntObj (result_ptr
->obj_ptr
, get_traceframe_number ());
1911 /* This implements the tcl command gdb_actions
1912 * It sets actions for a given tracepoint.
1915 * number: the tracepoint in question
1916 * actions: the actions to add to this tracepoint
1922 gdb_actions_command (clientData
, interp
, objc
, objv
)
1923 ClientData clientData
;
1926 Tcl_Obj
*CONST objv
[];
1928 struct tracepoint
*tp
;
1930 int nactions
, i
, len
;
1931 char *number
, *args
, *action
;
1933 struct action_line
*next
= NULL
, *temp
;
1934 enum actionline_type linetype
;
1938 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # args: should be: \"",
1939 Tcl_GetStringFromObj (objv
[0], NULL
),
1940 " number actions\"", NULL
);
1944 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
1945 tp
= get_tracepoint_by_number (&args
);
1948 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "Tracepoint \"", number
, "\" does not exist", NULL
);
1952 /* Free any existing actions */
1953 if (tp
->actions
!= NULL
)
1958 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
1960 /* Add the actions to the tracepoint */
1961 for (i
= 0; i
< nactions
; i
++)
1963 temp
= xmalloc (sizeof (struct action_line
));
1965 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
1966 temp
->action
= savestring (action
, len
);
1968 linetype
= validate_actionline (&(temp
->action
), tp
);
1970 if (linetype
== BADLINE
)
1992 * This section has commands that handle source disassembly.
1995 /* This implements the tcl command gdb_disassemble
1998 * source_with_assm - must be "source" or "nosource"
1999 * low_address - the address from which to start disassembly
2000 * ?hi_address? - the address to which to disassemble, defaults
2001 * to the end of the function containing low_address.
2003 * The disassembled code is passed to fputs_unfiltered, so it
2004 * either goes to the console if result_ptr->obj_ptr is NULL or to
2009 gdb_disassemble (clientData
, interp
, objc
, objv
)
2010 ClientData clientData
;
2013 Tcl_Obj
*CONST objv
[];
2015 CORE_ADDR pc
, low
, high
;
2016 int mixed_source_and_assembly
;
2017 static disassemble_info di
;
2018 static int di_initialized
;
2021 if (objc
!= 3 && objc
!= 4)
2022 error ("wrong # args");
2024 if (! di_initialized
)
2026 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
2027 (fprintf_ftype
) fprintf_unfiltered
);
2028 di
.flavour
= bfd_target_unknown_flavour
;
2029 di
.memory_error_func
= dis_asm_memory_error
;
2030 di
.print_address_func
= dis_asm_print_address
;
2034 di
.mach
= tm_print_insn_info
.mach
;
2035 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
2036 di
.endian
= BFD_ENDIAN_BIG
;
2038 di
.endian
= BFD_ENDIAN_LITTLE
;
2040 arg_ptr
= Tcl_GetStringFromObj (objv
[1], NULL
);
2041 if (*arg_ptr
== 's' && strcmp (arg_ptr
, "source") == 0)
2042 mixed_source_and_assembly
= 1;
2043 else if (*arg_ptr
== 'n' && strcmp (arg_ptr
, "nosource") == 0)
2044 mixed_source_and_assembly
= 0;
2046 error ("First arg must be 'source' or 'nosource'");
2048 low
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[2], NULL
));
2052 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
2053 error ("No function contains specified address");
2056 high
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[3], NULL
));
2058 /* If disassemble_from_exec == -1, then we use the following heuristic to
2059 determine whether or not to do disassembly from target memory or from the
2062 If we're debugging a local process, read target memory, instead of the
2063 exec file. This makes disassembly of functions in shared libs work
2066 Else, we're debugging a remote process, and should disassemble from the
2067 exec file for speed. However, this is no good if the target modifies its
2068 code (for relocation, or whatever).
2071 if (disassemble_from_exec
== -1)
2073 if (strcmp (target_shortname
, "child") == 0
2074 || strcmp (target_shortname
, "procfs") == 0
2075 || strcmp (target_shortname
, "vxprocess") == 0)
2076 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
2078 disassemble_from_exec
= 1; /* It's remote, read the exec file */
2081 if (disassemble_from_exec
)
2082 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
2084 di
.read_memory_func
= dis_asm_read_memory
;
2086 /* If just doing straight assembly, all we need to do is disassemble
2087 everything between low and high. If doing mixed source/assembly, we've
2088 got a totally different path to follow. */
2090 if (mixed_source_and_assembly
)
2091 { /* Come here for mixed source/assembly */
2092 /* The idea here is to present a source-O-centric view of a function to
2093 the user. This means that things are presented in source order, with
2094 (possibly) out of order assembly immediately following. */
2095 struct symtab
*symtab
;
2096 struct linetable_entry
*le
;
2099 struct my_line_entry
*mle
;
2100 struct symtab_and_line sal
;
2105 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
2107 if (!symtab
|| !symtab
->linetable
)
2110 /* First, convert the linetable to a bunch of my_line_entry's. */
2112 le
= symtab
->linetable
->item
;
2113 nlines
= symtab
->linetable
->nitems
;
2118 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
2122 /* Copy linetable entries for this function into our data structure, creating
2123 end_pc's and setting out_of_order as appropriate. */
2125 /* First, skip all the preceding functions. */
2127 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
2129 /* Now, copy all entries before the end of this function. */
2132 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
2134 if (le
[i
].line
== le
[i
+ 1].line
2135 && le
[i
].pc
== le
[i
+ 1].pc
)
2136 continue; /* Ignore duplicates */
2138 mle
[newlines
].line
= le
[i
].line
;
2139 if (le
[i
].line
> le
[i
+ 1].line
)
2141 mle
[newlines
].start_pc
= le
[i
].pc
;
2142 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
2146 /* If we're on the last line, and it's part of the function, then we need to
2147 get the end pc in a special way. */
2152 mle
[newlines
].line
= le
[i
].line
;
2153 mle
[newlines
].start_pc
= le
[i
].pc
;
2154 sal
= find_pc_line (le
[i
].pc
, 0);
2155 mle
[newlines
].end_pc
= sal
.end
;
2159 /* Now, sort mle by line #s (and, then by addresses within lines). */
2162 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
2164 /* Now, for each line entry, emit the specified lines (unless they have been
2165 emitted before), followed by the assembly code for that line. */
2167 next_line
= 0; /* Force out first line */
2168 for (i
= 0; i
< newlines
; i
++)
2170 /* Print out everything from next_line to the current line. */
2172 if (mle
[i
].line
>= next_line
)
2175 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
2177 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
2179 next_line
= mle
[i
].line
+ 1;
2182 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
2185 fputs_unfiltered (" ", gdb_stdout
);
2186 print_address (pc
, gdb_stdout
);
2187 fputs_unfiltered (":\t ", gdb_stdout
);
2188 pc
+= (*tm_print_insn
) (pc
, &di
);
2189 fputs_unfiltered ("\n", gdb_stdout
);
2196 for (pc
= low
; pc
< high
; )
2199 fputs_unfiltered (" ", gdb_stdout
);
2200 print_address (pc
, gdb_stdout
);
2201 fputs_unfiltered (":\t ", gdb_stdout
);
2202 pc
+= (*tm_print_insn
) (pc
, &di
);
2203 fputs_unfiltered ("\n", gdb_stdout
);
2207 gdb_flush (gdb_stdout
);
2212 /* This is the memory_read_func for gdb_disassemble when we are
2213 disassembling from the exec file. */
2216 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
2220 disassemble_info
*info
;
2222 extern struct target_ops exec_ops
;
2226 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
2237 /* This will be passed to qsort to sort the results of the disassembly */
2240 compare_lines (mle1p
, mle2p
)
2244 struct my_line_entry
*mle1
, *mle2
;
2247 mle1
= (struct my_line_entry
*) mle1p
;
2248 mle2
= (struct my_line_entry
*) mle2p
;
2250 val
= mle1
->line
- mle2
->line
;
2255 return mle1
->start_pc
- mle2
->start_pc
;
2258 /* This implements the TCL command `gdb_loc',
2261 * ?symbol? The symbol or address to locate - defaults to pc
2263 * a list consisting of the following:
2264 * basename, function name, filename, line number, address, current pc
2268 gdb_loc (clientData
, interp
, objc
, objv
)
2269 ClientData clientData
;
2272 Tcl_Obj
*CONST objv
[];
2275 struct symtab_and_line sal
;
2276 char *funcname
, *fname
;
2279 if (!have_full_symbols () && !have_partial_symbols ())
2281 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No symbol table is loaded", -1);
2287 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
2289 /* Note - this next line is not correct on all architectures. */
2290 /* For a graphical debugger we really want to highlight the */
2291 /* assembly line that called the next function on the stack. */
2292 /* Many architectures have the next instruction saved as the */
2293 /* pc on the stack, so what happens is the next instruction is hughlighted. */
2295 pc
= selected_frame
->pc
;
2296 sal
= find_pc_line (selected_frame
->pc
,
2297 selected_frame
->next
!= NULL
2298 && !selected_frame
->next
->signal_handler_caller
2299 && !frame_in_dummy (selected_frame
->next
));
2304 sal
= find_pc_line (stop_pc
, 0);
2309 struct symtabs_and_lines sals
;
2312 sals
= decode_line_spec (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
2318 if (sals
.nelts
!= 1)
2320 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Ambiguous line spec", -1);
2327 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
2332 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2333 Tcl_NewStringObj (sal
.symtab
->filename
, -1));
2335 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewStringObj ("", 0));
2337 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
2338 fname
= cplus_demangle (funcname
, 0);
2341 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2342 Tcl_NewStringObj (fname
, -1));
2346 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2347 Tcl_NewStringObj (funcname
, -1));
2349 filename
= symtab_to_filename (sal
.symtab
);
2350 if (filename
== NULL
)
2353 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2354 Tcl_NewStringObj (filename
, -1));
2355 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(sal
.line
)); /* line number */
2356 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
2357 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
2361 /* This implements the Tcl command 'gdb_get_mem', which
2362 * dumps a block of memory
2364 * gdb_get_mem addr form size num aschar
2366 * addr: address of data to dump
2367 * form: a char indicating format
2368 * size: size of each element; 1,2,4, or 8 bytes
2369 * num: the number of bytes to read
2370 * acshar: an optional ascii character to use in ASCII dump
2373 * a list of elements followed by an optional ASCII dump
2377 gdb_get_mem (clientData
, interp
, objc
, objv
)
2378 ClientData clientData
;
2381 Tcl_Obj
*CONST objv
[];
2383 int size
, asize
, i
, j
, bc
;
2385 int nbytes
, rnum
, bpr
;
2387 char format
, c
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
2388 struct type
*val_type
;
2390 if (objc
< 6 || objc
> 7)
2392 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2393 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2397 if (Tcl_GetIntFromObj (interp
, objv
[3], &size
) != TCL_OK
)
2399 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2404 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid size, must be > 0", -1);
2408 if (Tcl_GetIntFromObj (interp
, objv
[4], &nbytes
) != TCL_OK
)
2410 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2415 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid number of bytes, must be > 0",
2420 if (Tcl_GetIntFromObj (interp
, objv
[5], &bpr
) != TCL_OK
)
2422 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2427 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid bytes per row, must be > 0", -1);
2431 if (Tcl_GetLongFromObj (interp
, objv
[1], &tmp
) != TCL_OK
)
2434 addr
= (CORE_ADDR
) tmp
;
2436 format
= *(Tcl_GetStringFromObj (objv
[2], NULL
));
2437 mbuf
= (char *)malloc (nbytes
+32);
2440 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Out of memory.", -1);
2444 memset (mbuf
, 0, nbytes
+32);
2447 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
2450 aschar
= *(Tcl_GetStringFromObj(objv
[6], NULL
));
2456 val_type
= builtin_type_char
;
2460 val_type
= builtin_type_short
;
2464 val_type
= builtin_type_int
;
2468 val_type
= builtin_type_long_long
;
2472 val_type
= builtin_type_char
;
2476 bc
= 0; /* count of bytes in a row */
2477 buff
[0] = '"'; /* buffer for ascii dump */
2478 bptr
= &buff
[1]; /* pointer for ascii dump */
2480 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Build up the result as a list... */
2482 for (i
=0; i
< nbytes
; i
+= size
)
2486 fputs_unfiltered ("N/A ", gdb_stdout
);
2488 for ( j
= 0; j
< size
; j
++)
2493 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
2497 for ( j
= 0; j
< size
; j
++)
2500 if (c
< 32 || c
> 126)
2512 if (aschar
&& (bc
>= bpr
))
2514 /* end of row. print it and reset variables */
2519 fputs_unfiltered (buff
, gdb_stdout
);
2524 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
2532 /* This implements the tcl command "gdb_loadfile"
2533 * It loads a c source file into a text widget.
2536 * widget: the name of the text widget to fill
2537 * filename: the name of the file to load
2538 * linenumbers: A boolean indicating whether or not to display line numbers.
2543 /* In this routine, we will build up a "line table", i.e. a
2544 * table of bits showing which lines in the source file are executible.
2545 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2547 * Its size limits the maximum number of lines
2548 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2549 * the file is loaded, so it is OK to make this very large.
2550 * Additional memory will be allocated if needed. */
2551 #define LTABLE_SIZE 20000
2553 gdb_loadfile (clientData
, interp
, objc
, objv
)
2554 ClientData clientData
;
2557 Tcl_Obj
*CONST objv
[];
2559 char *file
, *widget
;
2560 int linenumbers
, ln
, lnum
, ltable_size
;
2563 struct symtab
*symtab
;
2564 struct linetable_entry
*le
;
2567 Tcl_DString text_cmd_1
, text_cmd_2
, *cur_cmd
;
2568 char line
[1024], line_num_buf
[16];
2569 int prefix_len_1
, prefix_len_2
, cur_prefix_len
, widget_len
;
2574 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
2578 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
2579 if ( Tk_NameToWindow (interp
, widget
, Tk_MainWindow (interp
)) == NULL
)
2584 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
2585 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
2587 symtab
= full_lookup_symtab (file
);
2590 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "File not found in symtab", -1);
2595 file
= symtab_to_filename ( symtab
);
2596 if ((fp
= fopen ( file
, "r" )) == NULL
)
2598 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Can't open file for reading", -1);
2602 if (stat (file
, &st
) < 0)
2604 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
2609 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
2610 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
2612 mtime
= bfd_get_mtime(exec_bfd
);
2614 if (mtime
&& mtime
< st
.st_mtime
)
2615 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2618 /* Source linenumbers don't appear to be in order, and a sort is */
2619 /* too slow so the fastest solution is just to allocate a huge */
2620 /* array and set the array entry for each linenumber */
2622 ltable_size
= LTABLE_SIZE
;
2623 ltable
= (char *)malloc (LTABLE_SIZE
);
2626 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2631 memset (ltable
, 0, LTABLE_SIZE
);
2633 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
2635 le
= symtab
->linetable
->item
;
2636 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
2638 lnum
= le
->line
>> 3;
2639 if (lnum
>= ltable_size
)
2642 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
2643 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
2645 if (new_ltable
== NULL
)
2647 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2652 ltable
= new_ltable
;
2654 ltable
[lnum
] |= 1 << (le
->line
% 8);
2658 Tcl_DStringInit(&text_cmd_1
);
2659 Tcl_DStringInit(&text_cmd_2
);
2663 widget_len
= strlen (widget
);
2666 Tcl_DStringAppend (&text_cmd_1
, widget
, widget_len
);
2667 Tcl_DStringAppend (&text_cmd_2
, widget
, widget_len
);
2671 Tcl_DStringAppend (&text_cmd_1
, " insert end {-\t", -1);
2672 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2674 Tcl_DStringAppend (&text_cmd_2
, " insert end { \t", -1);
2675 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2677 while (fgets (line
+ 1, 980, fp
))
2679 sprintf (line_num_buf
, "%d", ln
);
2680 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2682 cur_cmd
= &text_cmd_1
;
2683 cur_prefix_len
= prefix_len_1
;
2684 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2685 Tcl_DStringAppend (cur_cmd
, "} break_tag", 11);
2689 cur_cmd
= &text_cmd_2
;
2690 cur_prefix_len
= prefix_len_2
;
2691 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2692 Tcl_DStringAppend (cur_cmd
, "} \"\"", 4);
2695 Tcl_DStringAppendElement (cur_cmd
, line
);
2696 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2698 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2699 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2705 Tcl_DStringAppend (&text_cmd_1
, " insert end {- } break_tag", -1);
2706 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2707 Tcl_DStringAppend (&text_cmd_2
, " insert end { } \"\"", -1);
2708 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2710 while (fgets (line
+ 1, 980, fp
))
2712 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2714 cur_cmd
= &text_cmd_1
;
2715 cur_prefix_len
= prefix_len_1
;
2719 cur_cmd
= &text_cmd_2
;
2720 cur_prefix_len
= prefix_len_2
;
2723 Tcl_DStringAppendElement (cur_cmd
, line
);
2724 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2726 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2727 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2733 Tcl_DStringFree (&text_cmd_1
);
2734 Tcl_DStringFree (&text_cmd_2
);
2741 * This section contains commands for manipulation of breakpoints.
2745 /* set a breakpoint by source file and line number */
2746 /* flags are as follows: */
2747 /* least significant 2 bits are disposition, rest is */
2748 /* type (normally 0).
2751 bp_breakpoint, Normal breakpoint
2752 bp_hardware_breakpoint, Hardware assisted breakpoint
2755 Disposition of breakpoint. Ie: what to do after hitting it.
2758 del_at_next_stop, Delete at next stop, whether hit or not
2760 donttouch Leave it alone
2764 /* This implements the tcl command "gdb_set_bp"
2765 * It sets breakpoints, and runs the Tcl command
2766 * gdbtk_tcl_breakpoint create
2767 * to register the new breakpoint with the GUI.
2770 * filename: the file in which to set the breakpoint
2771 * line: the line number for the breakpoint
2772 * type: the type of the breakpoint
2774 * The return value of the call to gdbtk_tcl_breakpoint.
2778 gdb_set_bp (clientData
, interp
, objc
, objv
)
2779 ClientData clientData
;
2782 Tcl_Obj
*CONST objv
[];
2785 struct symtab_and_line sal
;
2786 int line
, flags
, ret
;
2787 struct breakpoint
*b
;
2793 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
2797 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
2798 if (sal
.symtab
== NULL
)
2801 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
2803 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2807 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
2809 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2814 if (!find_line_pc (sal
.symtab
, sal
.line
, &sal
.pc
))
2817 sal
.section
= find_pc_overlay (sal
.pc
);
2818 b
= set_raw_breakpoint (sal
);
2819 set_breakpoint_count (breakpoint_count
+ 1);
2820 b
->number
= breakpoint_count
;
2821 b
->type
= flags
>> 2;
2822 b
->disposition
= flags
& 3;
2824 /* FIXME: this won't work for duplicate basenames! */
2825 sprintf (buf
, "%s:%d", basename (Tcl_GetStringFromObj ( objv
[1], NULL
)), line
);
2826 b
->addr_string
= strsave (buf
);
2828 /* now send notification command back to GUI */
2830 Tcl_DStringInit (&cmd
);
2832 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2833 sprintf (buf
, "%d", b
->number
);
2834 Tcl_DStringAppendElement(&cmd
, buf
);
2835 sprintf (buf
, "0x%lx", (long)sal
.pc
);
2836 Tcl_DStringAppendElement (&cmd
, buf
);
2837 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[2], NULL
));
2838 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[1], NULL
));
2840 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2841 Tcl_DStringFree (&cmd
);
2845 /* This implements the tcl command gdb_get_breakpoint_info
2851 * A list with {file, function, line_number, address, type, enabled?,
2852 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
2856 gdb_get_breakpoint_info (clientData
, interp
, objc
, objv
)
2857 ClientData clientData
;
2860 Tcl_Obj
*CONST objv
[];
2862 struct symtab_and_line sal
;
2863 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
2864 "finish", "watchpoint", "hardware watchpoint",
2865 "read watchpoint", "access watchpoint",
2866 "longjmp", "longjmp resume", "step resume",
2867 "through sigtramp", "watchpoint scope",
2869 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
2870 struct command_line
*cmd
;
2872 struct breakpoint
*b
;
2873 extern struct breakpoint
*breakpoint_chain
;
2874 char *funcname
, *fname
, *filename
;
2879 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong number of args, should be \"breakpoint\"", -1);
2883 if ( Tcl_GetIntFromObj(NULL
, objv
[1], &bpnum
) != TCL_OK
)
2885 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2889 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2890 if (b
->number
== bpnum
)
2893 if (!b
|| b
->type
!= bp_breakpoint
)
2895 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Breakpoint #%d does not exist", -1);
2899 sal
= find_pc_line (b
->address
, 0);
2901 filename
= symtab_to_filename (sal
.symtab
);
2902 if (filename
== NULL
)
2905 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
2906 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2907 Tcl_NewStringObj (filename
, -1));
2909 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
2910 fname
= cplus_demangle (funcname
, 0);
2913 new_obj
= Tcl_NewStringObj (fname
, -1);
2917 new_obj
= Tcl_NewStringObj (funcname
, -1);
2919 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2921 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->line_number
));
2922 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%lx", b
->address
);
2923 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2924 Tcl_NewStringObj (bptypes
[b
->type
], -1));
2925 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewBooleanObj(b
->enable
== enabled
));
2926 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2927 Tcl_NewStringObj (bpdisp
[b
->disposition
], -1));
2928 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->ignore_count
));
2930 new_obj
= Tcl_NewObj();
2931 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
2932 Tcl_ListObjAppendElement (NULL
, new_obj
,
2933 Tcl_NewStringObj (cmd
->line
, -1));
2934 Tcl_ListObjAppendElement(NULL
, result_ptr
->obj_ptr
, new_obj
);
2936 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2937 Tcl_NewStringObj (b
->cond_string
, -1));
2939 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->thread
));
2940 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->hit_count
));
2946 /* This implements the tcl command gdb_get_breakpoint_list
2947 * It builds up a list of the current breakpoints.
2952 * A list of breakpoint numbers.
2956 gdb_get_breakpoint_list (clientData
, interp
, objc
, objv
)
2957 ClientData clientData
;
2960 Tcl_Obj
*CONST objv
[];
2962 struct breakpoint
*b
;
2963 extern struct breakpoint
*breakpoint_chain
;
2967 error ("wrong number of args, none are allowed");
2969 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2970 if (b
->type
== bp_breakpoint
)
2972 new_obj
= Tcl_NewIntObj (b
->number
);
2973 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2979 /* The functions in this section deal with stacks and backtraces. */
2981 /* This implements the tcl command gdb_stack.
2982 * It builds up a list of stack frames.
2985 * start - starting stack frame
2986 * count - number of frames to inspect
2988 * A list of function names
2992 gdb_stack (clientData
, interp
, objc
, objv
) ClientData clientData
;
2995 Tcl_Obj
*CONST objv
[];
3001 Tcl_WrongNumArgs (interp
, 1, objv
, "start count");
3002 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3006 if (Tcl_GetIntFromObj (NULL
, objv
[1], &start
))
3008 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3011 if (Tcl_GetIntFromObj (NULL
, objv
[2], &count
))
3013 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
3017 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
3019 if (target_has_stack
)
3021 struct frame_info
*top
;
3022 struct frame_info
*fi
;
3024 /* Find the outermost frame */
3025 fi
= get_current_frame ();
3029 fi
= get_prev_frame (fi
);
3032 /* top now points to the top (outermost frame) of the
3033 stack, so point it to the requested start */
3035 top
= find_relative_frame (top
, &start
);
3037 /* If start != 0, then we have asked to start outputting
3038 frames beyond the innermost stack frame */
3042 while (fi
&& count
--)
3044 get_frame_name (interp
, result_ptr
->obj_ptr
, fi
);
3045 fi
= get_next_frame (fi
);
3053 /* A helper function for get_stack which adds information about
3054 * the stack frame FI to the caller's LIST.
3056 * This is stolen from print_frame_info in stack.c.
3059 get_frame_name (interp
, list
, fi
)
3062 struct frame_info
*fi
;
3064 struct symtab_and_line sal
;
3065 struct symbol
*func
= NULL
;
3066 register char *funname
= 0;
3067 enum language funlang
= language_unknown
;
3070 if (frame_in_dummy (fi
))
3072 objv
[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
3073 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3076 if (fi
->signal_handler_caller
)
3078 objv
[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
3079 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3084 find_pc_line (fi
->pc
,
3086 && !fi
->next
->signal_handler_caller
3087 && !frame_in_dummy (fi
->next
));
3089 func
= find_pc_function (fi
->pc
);
3092 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3094 && (SYMBOL_VALUE_ADDRESS (msymbol
)
3095 > BLOCK_START (SYMBOL_BLOCK_VALUE (func
))))
3098 funname
= SYMBOL_NAME (msymbol
);
3099 funlang
= SYMBOL_LANGUAGE (msymbol
);
3103 funname
= SYMBOL_NAME (func
);
3104 funlang
= SYMBOL_LANGUAGE (func
);
3109 struct minimal_symbol
*msymbol
= lookup_minimal_symbol_by_pc (fi
->pc
);
3110 if (msymbol
!= NULL
)
3112 funname
= SYMBOL_NAME (msymbol
);
3113 funlang
= SYMBOL_LANGUAGE (msymbol
);
3121 if (funlang
== language_cplus
)
3122 name
= cplus_demangle (funname
, 0);
3126 objv
[0] = Tcl_NewStringObj (name
, -1);
3127 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3132 /* we have no convenient way to deal with this yet... */
3133 if (fi
->pc
!= sal
.pc
|| !sal
.symtab
)
3135 print_address_numeric (fi
->pc
, 1, gdb_stdout
);
3136 printf_filtered (" in ");
3138 printf_symbol_filtered (gdb_stdout
, funname
? funname
: "??", funlang
,
3141 objv
[0] = Tcl_NewStringObj (funname
!= NULL
? funname
: "??", -1);
3142 #ifdef PC_LOAD_SEGMENT
3143 /* If we couldn't print out function name but if can figure out what
3144 load segment this pc value is from, at least print out some info
3145 about its load segment. */
3148 Tcl_AppendStringsToObj (objv
[0], " from ", PC_LOAD_SEGMENT (fi
->pc
),
3155 char *lib
= PC_SOLIB (fi
->pc
);
3158 Tcl_AppendStringsToObj (objv
[0], " from ", lib
, (char *) NULL
);
3162 Tcl_ListObjAppendElement (interp
, list
, objv
[0]);
3168 * This section contains a bunch of miscellaneous utility commands
3171 /* This implements the tcl command gdb_path_conv
3173 * On Windows, it canonicalizes the pathname,
3174 * On Unix, it is a no op.
3179 * The canonicalized path.
3183 gdb_path_conv (clientData
, interp
, objc
, objv
)
3184 ClientData clientData
;
3187 Tcl_Obj
*CONST objv
[];
3190 error ("wrong # args");
3194 char pathname
[256], *ptr
;
3196 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj(objv
[1], NULL
), pathname
);
3197 for (ptr
= pathname
; *ptr
; ptr
++)
3202 Tcl_SetStringObj (result_ptr
->obj_ptr
, pathname
, -1);
3205 Tcl_SetStringObj (result_ptr
->obj_ptr
, Tcl_GetStringFromObj (objv
[1], NULL
), -1);
3212 * This section has utility routines that are not Tcl commands.
3216 perror_with_name_wrapper (args
)
3219 perror_with_name (args
);
3223 /* The lookup_symtab() in symtab.c doesn't work correctly */
3224 /* It will not work will full pathnames and if multiple */
3225 /* source files have the same basename, it will return */
3226 /* the first one instead of the correct one. This version */
3227 /* also always makes sure symtab->fullname is set. */
3229 static struct symtab
*
3230 full_lookup_symtab(file
)
3234 struct objfile
*objfile
;
3235 char *bfile
, *fullname
;
3236 struct partial_symtab
*pt
;
3241 /* first try a direct lookup */
3242 st
= lookup_symtab (file
);
3246 symtab_to_filename(st
);
3250 /* if the direct approach failed, try */
3251 /* looking up the basename and checking */
3252 /* all matches with the fullname */
3253 bfile
= basename (file
);
3254 ALL_SYMTABS (objfile
, st
)
3256 if (!strcmp (bfile
, basename(st
->filename
)))
3259 fullname
= symtab_to_filename (st
);
3261 fullname
= st
->fullname
;
3263 if (!strcmp (file
, fullname
))
3268 /* still no luck? look at psymtabs */
3269 ALL_PSYMTABS (objfile
, pt
)
3271 if (!strcmp (bfile
, basename(pt
->filename
)))
3273 st
= PSYMTAB_TO_SYMTAB (pt
);
3276 fullname
= symtab_to_filename (st
);
3277 if (!strcmp (file
, fullname
))