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 used only in this file.
148 int Gdbtk_Init (Tcl_Interp
*interp
);
149 static int compare_lines
PARAMS ((const PTR
, const PTR
));
150 static int comp_files
PARAMS ((const void *, const void *));
151 static int call_wrapper
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
152 static int gdb_actions_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
153 Tcl_Obj
*CONST objv
[]));
154 static int gdb_changed_register_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
155 static int gdb_clear_file
PARAMS ((ClientData
, Tcl_Interp
*interp
, int, Tcl_Obj
*CONST
[]));
156 static int gdb_cmd
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
157 static int gdb_confirm_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
158 static int gdb_disassemble
PARAMS ((ClientData
, Tcl_Interp
*, int,
160 static int gdb_eval
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
161 static int gdb_fetch_registers
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
162 static int gdb_find_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
163 Tcl_Obj
*CONST objv
[]));
164 static int gdb_force_quit
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
165 static struct symtab
*full_lookup_symtab
PARAMS ((char *file
));
166 static int gdb_get_args_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
167 Tcl_Obj
*CONST objv
[]));
168 static int gdb_get_breakpoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
169 static int gdb_get_breakpoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
170 static int gdb_get_file_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
171 Tcl_Obj
*CONST objv
[]));
172 static int gdb_get_function_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
173 Tcl_Obj
*CONST objv
[]));
174 static int gdb_get_line_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
175 Tcl_Obj
*CONST objv
[]));
176 static int gdb_get_locals_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
177 Tcl_Obj
*CONST objv
[]));
178 static int gdb_get_mem
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
179 static int gdb_get_trace_frame_num
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
180 static int gdb_get_tracepoint_list
PARAMS ((ClientData
, Tcl_Interp
*, int,
181 Tcl_Obj
*CONST objv
[]));
182 static int gdb_get_vars_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
183 Tcl_Obj
*CONST objv
[]));
184 static int gdb_immediate_command
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
185 static int gdb_listfiles
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
186 static int gdb_listfuncs
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
187 static int gdb_loadfile
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
188 static int gdb_load_info
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
189 static int gdb_loc
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
190 static int gdb_path_conv
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
191 static int gdb_prompt_command
PARAMS ((ClientData
, Tcl_Interp
*, int,
192 Tcl_Obj
*CONST objv
[]));
193 static int gdb_regnames
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
194 static int gdb_search
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
196 static int gdb_set_bp
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST objv
[]));
197 static int gdb_stop
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
198 static int gdb_target_has_execution_command
PARAMS ((ClientData
, Tcl_Interp
*,
201 static int gdb_trace_status
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
202 static int gdb_tracepoint_exists_command
PARAMS ((ClientData
, Tcl_Interp
*,
204 Tcl_Obj
*CONST objv
[]));
205 static int gdb_get_tracepoint_info
PARAMS ((ClientData
, Tcl_Interp
*, int,
206 Tcl_Obj
*CONST objv
[]));
207 static int gdbtk_dis_asm_read_memory
PARAMS ((bfd_vma
, bfd_byte
*, int, disassemble_info
*));
208 static int get_pc_register
PARAMS ((ClientData
, Tcl_Interp
*, int, Tcl_Obj
*CONST
[]));
209 char * get_prompt
PARAMS ((void));
210 static void get_register
PARAMS ((int, void *));
211 static void get_register_name
PARAMS ((int, void *));
212 static int map_arg_registers
PARAMS ((int, Tcl_Obj
*CONST
[], void (*) (int, void *), void *));
213 static int perror_with_name_wrapper
PARAMS ((char *args
));
214 static void register_changed_p
PARAMS ((int, void *));
215 void TclDebug
PARAMS ((const char *fmt
, ...));
216 static int wrapped_call (char *opaque_args
);
219 * This loads all the Tcl commands into the Tcl interpreter.
222 * interp - The interpreter into which to load the commands.
225 * A standard Tcl result.
232 Tcl_CreateObjCommand (interp
, "gdb_cmd", call_wrapper
, gdb_cmd
, NULL
);
233 Tcl_CreateObjCommand (interp
, "gdb_immediate", call_wrapper
,
234 gdb_immediate_command
, NULL
);
235 Tcl_CreateObjCommand (interp
, "gdb_loc", call_wrapper
, gdb_loc
, NULL
);
236 Tcl_CreateObjCommand (interp
, "gdb_path_conv", call_wrapper
, gdb_path_conv
, NULL
);
237 Tcl_CreateObjCommand (interp
, "gdb_listfiles", call_wrapper
, gdb_listfiles
, NULL
);
238 Tcl_CreateObjCommand (interp
, "gdb_listfuncs", call_wrapper
, gdb_listfuncs
,
240 Tcl_CreateObjCommand (interp
, "gdb_get_mem", call_wrapper
, gdb_get_mem
,
242 Tcl_CreateObjCommand (interp
, "gdb_stop", call_wrapper
, gdb_stop
, NULL
);
243 Tcl_CreateObjCommand (interp
, "gdb_regnames", call_wrapper
, gdb_regnames
, NULL
);
244 Tcl_CreateObjCommand (interp
, "gdb_fetch_registers", call_wrapper
,
245 gdb_fetch_registers
, NULL
);
246 Tcl_CreateObjCommand (interp
, "gdb_changed_register_list", call_wrapper
,
247 gdb_changed_register_list
, NULL
);
248 Tcl_CreateObjCommand (interp
, "gdb_disassemble", call_wrapper
,
249 gdb_disassemble
, NULL
);
250 Tcl_CreateObjCommand (interp
, "gdb_eval", call_wrapper
, gdb_eval
, NULL
);
251 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_list", call_wrapper
,
252 gdb_get_breakpoint_list
, NULL
);
253 Tcl_CreateObjCommand (interp
, "gdb_get_breakpoint_info", call_wrapper
,
254 gdb_get_breakpoint_info
, NULL
);
255 Tcl_CreateObjCommand (interp
, "gdb_clear_file", call_wrapper
,
256 gdb_clear_file
, NULL
);
257 Tcl_CreateObjCommand (interp
, "gdb_confirm_quit", call_wrapper
,
258 gdb_confirm_quit
, NULL
);
259 Tcl_CreateObjCommand (interp
, "gdb_force_quit", call_wrapper
,
260 gdb_force_quit
, NULL
);
261 Tcl_CreateObjCommand (interp
, "gdb_target_has_execution",
263 gdb_target_has_execution_command
, NULL
);
264 Tcl_CreateObjCommand (interp
, "gdb_is_tracing",
265 call_wrapper
, gdb_trace_status
,
267 Tcl_CreateObjCommand (interp
, "gdb_load_info", call_wrapper
, gdb_load_info
, NULL
);
268 Tcl_CreateObjCommand (interp
, "gdb_get_locals", call_wrapper
, gdb_get_locals_command
,
270 Tcl_CreateObjCommand (interp
, "gdb_get_args", call_wrapper
, gdb_get_args_command
,
272 Tcl_CreateObjCommand (interp
, "gdb_get_function", call_wrapper
, gdb_get_function_command
,
274 Tcl_CreateObjCommand (interp
, "gdb_get_line", call_wrapper
, gdb_get_line_command
,
276 Tcl_CreateObjCommand (interp
, "gdb_get_file", call_wrapper
, gdb_get_file_command
,
278 Tcl_CreateObjCommand (interp
, "gdb_tracepoint_exists",
279 call_wrapper
, gdb_tracepoint_exists_command
, NULL
);
280 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_info",
281 call_wrapper
, gdb_get_tracepoint_info
, NULL
);
282 Tcl_CreateObjCommand (interp
, "gdb_actions",
283 call_wrapper
, gdb_actions_command
, NULL
);
284 Tcl_CreateObjCommand (interp
, "gdb_prompt",
285 call_wrapper
, gdb_prompt_command
, NULL
);
286 Tcl_CreateObjCommand (interp
, "gdb_find_file",
287 call_wrapper
, gdb_find_file_command
, NULL
);
288 Tcl_CreateObjCommand (interp
, "gdb_get_tracepoint_list",
289 call_wrapper
, gdb_get_tracepoint_list
, NULL
);
290 Tcl_CreateObjCommand (interp
, "gdb_pc_reg", call_wrapper
, get_pc_register
, NULL
);
291 Tcl_CreateObjCommand (interp
, "gdb_loadfile", call_wrapper
, gdb_loadfile
, NULL
);
292 Tcl_CreateObjCommand (gdbtk_interp
, "gdb_search", call_wrapper
,
294 Tcl_CreateObjCommand (interp
, "gdb_set_bp", call_wrapper
, gdb_set_bp
, NULL
);
295 Tcl_CreateObjCommand (interp
, "gdb_get_trace_frame_num",
296 call_wrapper
, gdb_get_trace_frame_num
, NULL
);
298 Tcl_PkgProvide(interp
, "Gdbtk", GDBTK_VERSION
);
302 /* This routine acts as a top-level for all GDB code called by Tcl/Tk. It
303 handles cleanups, and uses catch_errors to trap calls to return_to_top_level
305 This is necessary in order to prevent a longjmp out of the bowels of Tk,
306 possibly leaving things in a bad state. Since this routine can be called
307 recursively, it needs to save and restore the contents of the result_ptr as
311 call_wrapper (clientData
, interp
, objc
, objv
)
312 ClientData clientData
;
315 Tcl_Obj
*CONST objv
[];
317 struct wrapped_call_args wrapped_args
;
318 gdbtk_result new_result
, *old_result_ptr
;
320 old_result_ptr
= result_ptr
;
321 result_ptr
= &new_result
;
322 result_ptr
->obj_ptr
= Tcl_NewObj();
323 result_ptr
->flags
= GDBTK_TO_RESULT
;
325 wrapped_args
.func
= (Tcl_ObjCmdProc
*) clientData
;
326 wrapped_args
.interp
= interp
;
327 wrapped_args
.objc
= objc
;
328 wrapped_args
.objv
= objv
;
329 wrapped_args
.val
= TCL_OK
;
331 if (!catch_errors (wrapped_call
, &wrapped_args
, "", RETURN_MASK_ALL
))
334 wrapped_args
.val
= TCL_ERROR
; /* Flag an error for TCL */
336 /* Make sure the timer interrupts are turned off. */
340 gdb_flush (gdb_stderr
); /* Flush error output */
341 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
343 /* If we errored out here, and the results were going to the
344 console, then gdbtk_fputs will have gathered the result into the
345 result_ptr. We also need to echo them out to the console here */
347 gdb_flush (gdb_stderr
); /* Flush error output */
348 gdb_flush (gdb_stdout
); /* Sometimes error output comes here as well */
350 /* In case of an error, we may need to force the GUI into idle
351 mode because gdbtk_call_command may have bombed out while in
352 the command routine. */
355 Tcl_Eval (interp
, "gdbtk_tcl_idle");
359 /* do not suppress any errors -- a remote target could have errored */
360 load_in_progress
= 0;
363 * Now copy the result over to the true Tcl result. If GDBTK_TO_RESULT flag
364 * bit is set , this just copies a null object over to the Tcl result, which is
365 * fine because we should reset the result in this case anyway.
367 if (result_ptr
->flags
& GDBTK_IN_TCL_RESULT
)
369 Tcl_DecrRefCount(result_ptr
->obj_ptr
);
373 Tcl_SetObjResult (interp
, result_ptr
->obj_ptr
);
376 result_ptr
= old_result_ptr
;
382 return wrapped_args
.val
;
386 * This is the wrapper that is passed to catch_errors.
390 wrapped_call (opaque_args
)
393 struct wrapped_call_args
*args
= (struct wrapped_call_args
*) opaque_args
;
394 args
->val
= (*args
->func
) (args
->func
, args
->interp
, args
->objc
, args
->objv
);
398 /* This is a convenience function to sprintf something(s) into a
399 * new element in a Tcl list object.
403 #ifdef ANSI_PROTOTYPES
404 sprintf_append_element_to_obj (Tcl_Obj
*objp
, char *format
, ...)
406 sprintf_append_element_to_obj (va_alist
)
413 #ifdef ANSI_PROTOTYPES
414 va_start (args
, format
);
420 dsp
= va_arg (args
, Tcl_Obj
*);
421 format
= va_arg (args
, char *);
424 vsprintf (buf
, format
, args
);
426 Tcl_ListObjAppendElement (NULL
, objp
, Tcl_NewStringObj (buf
, -1));
430 * This section contains the commands that control execution.
433 /* This implements the tcl command gdb_clear_file.
435 * Prepare to accept a new executable file. This is called when we
436 * want to clear away everything we know about the old file, without
437 * asking the user. The Tcl code will have already asked the user if
438 * necessary. After this is called, we should be able to run the
439 * `file' command without getting any questions.
448 gdb_clear_file (clientData
, interp
, objc
, objv
)
449 ClientData clientData
;
452 Tcl_Obj
*CONST objv
[];
455 Tcl_SetStringObj (result_ptr
->obj_ptr
,
456 "Wrong number of args, none are allowed.", -1);
458 if (inferior_pid
!= 0 && target_has_execution
)
461 target_detach (NULL
, 0);
466 if (target_has_execution
)
469 symbol_file_command (NULL
, 0);
471 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
472 clear it here. FIXME: This seems like an abstraction violation
479 /* This implements the tcl command gdb_confirm_quit
480 * Ask the user to confirm an exit request.
485 * A boolean, 1 if the user answered yes, 0 if no.
489 gdb_confirm_quit (clientData
, interp
, objc
, objv
)
490 ClientData clientData
;
493 Tcl_Obj
*CONST objv
[];
499 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
503 ret
= quit_confirm ();
504 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, ret
);
508 /* This implements the tcl command gdb_force_quit
509 * Quit without asking for confirmation.
518 gdb_force_quit (clientData
, interp
, objc
, objv
)
519 ClientData clientData
;
522 Tcl_Obj
*CONST objv
[];
526 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Wrong number of args, should be none.", -1);
530 quit_force ((char *) NULL
, 1);
534 /* This implements the tcl command gdb_stop
535 * It stops the target in a continuable fashion.
544 gdb_stop (clientData
, interp
, objc
, objv
)
545 ClientData clientData
;
548 Tcl_Obj
*CONST objv
[];
555 quit_flag
= 1; /* hope something sees this */
562 * This section contains Tcl commands that are wrappers for invoking
563 * the GDB command interpreter.
567 /* This implements the tcl command `gdb_eval'.
568 * It uses the gdb evaluator to return the value of
569 * an expression in the current language
572 * expression - the expression to evaluate.
574 * The result of the evaluation.
578 gdb_eval (clientData
, interp
, objc
, objv
)
579 ClientData clientData
;
582 Tcl_Obj
*CONST objv
[];
584 struct expression
*expr
;
585 struct cleanup
*old_chain
=NULL
;
590 Tcl_SetStringObj (result_ptr
->obj_ptr
,
591 "wrong # args, should be \"gdb_eval expression\"", -1);
595 expr
= parse_expression (Tcl_GetStringFromObj (objv
[1], NULL
));
597 old_chain
= make_cleanup (free_current_contents
, &expr
);
599 val
= evaluate_expression (expr
);
602 * Print the result of the expression evaluation. This will go to
603 * eventually go to gdbtk_fputs, and from there be collected into
607 val_print (VALUE_TYPE (val
), VALUE_CONTENTS (val
), VALUE_ADDRESS (val
),
608 gdb_stdout
, 0, 0, 0, 0);
610 do_cleanups (old_chain
);
615 /* This implements the tcl command "gdb_cmd".
617 * It sends its argument to the GDB command scanner for execution.
618 * This command will never cause the update, idle and busy hooks to be called
622 * command - The GDB command to execute
624 * The output from the gdb command (except for the "load" & "while"
625 * which dump their output to the console.
629 gdb_cmd (clientData
, interp
, objc
, objv
)
630 ClientData clientData
;
633 Tcl_Obj
*CONST objv
[];
638 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
642 if (running_now
|| load_in_progress
)
647 /* for the load instruction (and possibly others later) we
648 set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
649 will not buffer all the data until the command is finished. */
651 if ((strncmp ("load ", Tcl_GetStringFromObj (objv
[1], NULL
), 5) == 0)
652 || (strncmp ("while ", Tcl_GetStringFromObj (objv
[1], NULL
), 6) == 0))
654 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
655 load_in_progress
= 1;
656 gdbtk_start_timer ();
659 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
661 if (load_in_progress
)
664 load_in_progress
= 0;
665 result_ptr
->flags
|= GDBTK_TO_RESULT
;
668 bpstat_do_actions (&stop_bpstat
);
674 * This implements the tcl command "gdb_immediate"
676 * It does exactly the same thing as gdb_cmd, except NONE of its outut
677 * is buffered. This will also ALWAYS cause the busy, update, and idle hooks to
678 * be called, contrasted with gdb_cmd, which NEVER calls them.
679 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
680 * to the console window.
683 * command - The GDB command to execute
689 gdb_immediate_command (clientData
, interp
, objc
, objv
)
690 ClientData clientData
;
693 Tcl_Obj
*CONST objv
[];
698 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
702 if (running_now
|| load_in_progress
)
707 result_ptr
->flags
&= ~GDBTK_TO_RESULT
;
709 execute_command (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
711 bpstat_do_actions (&stop_bpstat
);
713 result_ptr
->flags
|= GDBTK_TO_RESULT
;
718 /* This implements the tcl command "gdb_prompt"
720 * It returns the gdb interpreter's prompt.
729 gdb_prompt_command (clientData
, interp
, objc
, objv
)
730 ClientData clientData
;
733 Tcl_Obj
*CONST objv
[];
735 Tcl_SetStringObj (result_ptr
->obj_ptr
, get_prompt (), -1);
741 * This section contains general informational commands.
744 /* This implements the tcl command "gdb_target_has_execution"
746 * Tells whether the target is executing.
751 * A boolean indicating whether the target is executing.
755 gdb_target_has_execution_command (clientData
, interp
, objc
, objv
)
756 ClientData clientData
;
759 Tcl_Obj
*CONST objv
[];
763 if (target_has_execution
&& inferior_pid
!= 0)
766 Tcl_SetBooleanObj (result_ptr
->obj_ptr
, result
);
770 /* This implements the tcl command "gdb_load_info"
772 * It returns information about the file about to be downloaded.
775 * filename: The file to open & get the info on.
777 * A list consisting of the name and size of each section.
781 gdb_load_info (clientData
, interp
, objc
, objv
)
782 ClientData clientData
;
785 Tcl_Obj
*CONST objv
[];
788 struct cleanup
*old_cleanups
;
792 char *filename
= Tcl_GetStringFromObj (objv
[1], NULL
);
794 loadfile_bfd
= bfd_openr (filename
, gnutarget
);
795 if (loadfile_bfd
== NULL
)
797 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Open failed", -1);
800 old_cleanups
= make_cleanup (bfd_close
, loadfile_bfd
);
802 if (!bfd_check_format (loadfile_bfd
, bfd_object
))
804 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Bad Object File", -1);
808 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
810 for (s
= loadfile_bfd
->sections
; s
; s
= s
->next
)
812 if (s
->flags
& SEC_LOAD
)
814 bfd_size_type size
= bfd_get_section_size_before_reloc (s
);
817 ob
[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd
, s
), -1);
818 ob
[1] = Tcl_NewLongObj ((long) size
);
819 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewListObj (2, ob
));
824 do_cleanups (old_cleanups
);
830 * This and gdb_get_locals just call gdb_get_vars_command with the right
831 * value of clientData. We can't use the client data in the definition
832 * of the command, because the call wrapper uses this instead...
836 gdb_get_locals_command (clientData
, interp
, objc
, objv
)
837 ClientData clientData
;
840 Tcl_Obj
*CONST objv
[];
843 return gdb_get_vars_command((ClientData
) 0, interp
, objc
, objv
);
848 gdb_get_args_command (clientData
, interp
, objc
, objv
)
849 ClientData clientData
;
852 Tcl_Obj
*CONST objv
[];
855 return gdb_get_vars_command((ClientData
) 1, interp
, objc
, objv
);
859 /* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
861 * This function sets the Tcl interpreter's result to a list of variable names
862 * depending on clientData. If clientData is one, the result is a list of
863 * arguments; zero returns a list of locals -- all relative to the block
864 * specified as an argument to the command. Valid commands include
865 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
869 * block - the address within which to specify the locals or args.
871 * A list of the locals or args
875 gdb_get_vars_command (clientData
, interp
, objc
, objv
)
876 ClientData clientData
;
879 Tcl_Obj
*CONST objv
[];
881 struct symtabs_and_lines sals
;
884 char **canonical
, *args
;
885 int i
, nsyms
, arguments
;
889 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
,
890 "wrong # of args: should be \"",
891 Tcl_GetStringFromObj (objv
[0], NULL
),
892 " function:line|function|line|*addr\"", NULL
);
896 arguments
= (int) clientData
;
897 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
898 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
901 Tcl_SetStringObj (result_ptr
->obj_ptr
,
902 "error decoding line", -1);
906 /* Initialize the result pointer to an empty list. */
908 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
910 /* Resolve all line numbers to PC's */
911 for (i
= 0; i
< sals
.nelts
; i
++)
912 resolve_sal_pc (&sals
.sals
[i
]);
914 block
= block_for_pc (sals
.sals
[0].pc
);
917 nsyms
= BLOCK_NSYMS (block
);
918 for (i
= 0; i
< nsyms
; i
++)
920 sym
= BLOCK_SYM (block
, i
);
921 switch (SYMBOL_CLASS (sym
)) {
923 case LOC_UNDEF
: /* catches errors */
924 case LOC_CONST
: /* constant */
925 case LOC_STATIC
: /* static */
926 case LOC_REGISTER
: /* register */
927 case LOC_TYPEDEF
: /* local typedef */
928 case LOC_LABEL
: /* local label */
929 case LOC_BLOCK
: /* local function */
930 case LOC_CONST_BYTES
: /* loc. byte seq. */
931 case LOC_UNRESOLVED
: /* unresolved static */
932 case LOC_OPTIMIZED_OUT
: /* optimized out */
934 case LOC_ARG
: /* argument */
935 case LOC_REF_ARG
: /* reference arg */
936 case LOC_REGPARM
: /* register arg */
937 case LOC_REGPARM_ADDR
: /* indirect register arg */
938 case LOC_LOCAL_ARG
: /* stack arg */
939 case LOC_BASEREG_ARG
: /* basereg arg */
941 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
942 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
944 case LOC_LOCAL
: /* stack local */
945 case LOC_BASEREG
: /* basereg local */
947 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
948 Tcl_NewStringObj (SYMBOL_NAME (sym
), -1));
952 if (BLOCK_FUNCTION (block
))
955 block
= BLOCK_SUPERBLOCK (block
);
961 /* This implements the tcl command "gdb_get_line"
963 * It returns the linenumber for a given linespec. It will take any spec
964 * that can be passed to decode_line_1
967 * linespec - the line specification
969 * The line number for that spec.
972 gdb_get_line_command (clientData
, interp
, objc
, objv
)
973 ClientData clientData
;
976 Tcl_Obj
*CONST objv
[];
978 struct symtabs_and_lines sals
;
979 char *args
, **canonical
;
983 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
984 Tcl_GetStringFromObj (objv
[0], NULL
),
985 " linespec\"", NULL
);
989 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
990 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
993 Tcl_SetIntObj (result_ptr
->obj_ptr
, sals
.sals
[0].line
);
997 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1002 /* This implements the tcl command "gdb_get_file"
1004 * It returns the file containing a given line spec.
1007 * linespec - The linespec to look up
1009 * The file containing it.
1013 gdb_get_file_command (clientData
, interp
, objc
, objv
)
1014 ClientData clientData
;
1017 Tcl_Obj
*CONST objv
[];
1019 struct symtabs_and_lines sals
;
1020 char *args
, **canonical
;
1024 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1025 Tcl_GetStringFromObj (objv
[0], NULL
),
1026 " linespec\"", NULL
);
1030 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1031 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1032 if (sals
.nelts
== 1)
1034 Tcl_SetStringObj (result_ptr
->obj_ptr
, sals
.sals
[0].symtab
->filename
, -1);
1038 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1042 /* This implements the tcl command "gdb_get_function"
1044 * It finds the function containing the given line spec.
1047 * linespec - The line specification
1049 * The function that contains it, or "N/A" if it is not in a function.
1052 gdb_get_function_command (clientData
, interp
, objc
, objv
)
1053 ClientData clientData
;
1056 Tcl_Obj
*CONST objv
[];
1059 struct symtabs_and_lines sals
;
1060 char *args
, **canonical
;
1064 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1065 Tcl_GetStringFromObj (objv
[0], NULL
),
1066 " linespec\"", NULL
);
1070 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1071 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1072 if (sals
.nelts
== 1)
1074 resolve_sal_pc (&sals
.sals
[0]);
1075 find_pc_partial_function (sals
.sals
[0].pc
, &function
, NULL
, NULL
);
1076 if (function
!= NULL
)
1078 Tcl_SetStringObj (result_ptr
->obj_ptr
, function
, -1);
1083 Tcl_SetStringObj (result_ptr
->obj_ptr
, "N/A", -1);
1087 /* This implements the tcl command "gdb_find_file"
1089 * It searches the symbol tables to get the full pathname to a file.
1092 * filename: the file name to search for.
1094 * The full path to the file, or an empty string if the file is not
1099 gdb_find_file_command (clientData
, interp
, objc
, objv
)
1100 ClientData clientData
;
1103 Tcl_Obj
*CONST objv
[];
1105 char *filename
= NULL
;
1110 Tcl_WrongNumArgs(interp
, 1, objv
, "filename");
1114 st
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1116 filename
= st
->fullname
;
1118 if (filename
== NULL
)
1119 Tcl_SetStringObj (result_ptr
->obj_ptr
, "", 0);
1121 Tcl_SetStringObj (result_ptr
->obj_ptr
, filename
, -1);
1126 /* This implements the tcl command "gdb_listfiles"
1128 * This lists all the files in the current executible.
1130 * Note that this currently pulls in all sorts of filenames
1131 * that aren't really part of the executable. It would be
1132 * best if we could check each file to see if it actually
1133 * contains executable lines of code, but we can't do that
1137 * ?pathname? - If provided, only files which match pathname
1138 * (up to strlen(pathname)) are included. THIS DOES NOT
1139 * CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1140 * THE FULL PATHNAME!!!
1143 * A list of all matching files.
1146 gdb_listfiles (clientData
, interp
, objc
, objv
)
1147 ClientData clientData
;
1150 Tcl_Obj
*CONST objv
[];
1152 struct objfile
*objfile
;
1153 struct partial_symtab
*psymtab
;
1154 struct symtab
*symtab
;
1155 char *lastfile
, *pathname
=NULL
, **files
;
1157 int i
, numfiles
= 0, len
= 0;
1160 files
= (char **) xmalloc (sizeof (char *) * files_size
);
1164 Tcl_WrongNumArgs (interp
, 1, objv
, "Usage: gdb_listfiles ?pathname?");
1168 pathname
= Tcl_GetStringFromObj (objv
[1], &len
);
1170 ALL_PSYMTABS (objfile
, psymtab
)
1172 if (numfiles
== files_size
)
1174 files_size
= files_size
* 2;
1175 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1177 if (psymtab
->filename
)
1179 if (!len
|| !strncmp(pathname
, psymtab
->filename
,len
)
1180 || !strcmp(psymtab
->filename
, basename(psymtab
->filename
)))
1182 files
[numfiles
++] = basename(psymtab
->filename
);
1187 ALL_SYMTABS (objfile
, symtab
)
1189 if (numfiles
== files_size
)
1191 files_size
= files_size
* 2;
1192 files
= (char **) xrealloc (files
, sizeof (char *) * files_size
);
1194 if (symtab
->filename
&& symtab
->linetable
&& symtab
->linetable
->nitems
)
1196 if (!len
|| !strncmp(pathname
, symtab
->filename
,len
)
1197 || !strcmp(symtab
->filename
, basename(symtab
->filename
)))
1199 files
[numfiles
++] = basename(symtab
->filename
);
1204 qsort (files
, numfiles
, sizeof(char *), comp_files
);
1208 /* Discard the old result pointer, in case it has accumulated anything
1209 and set it to a new list object */
1211 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1213 for (i
= 0; i
< numfiles
; i
++)
1215 if (strcmp(files
[i
],lastfile
))
1216 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj(files
[i
], -1));
1217 lastfile
= files
[i
];
1225 comp_files (file1
, file2
)
1226 const void *file1
, *file2
;
1228 return strcmp(* (char **) file1
, * (char **) file2
);
1232 /* This implements the tcl command "gdb_search"
1236 * option - One of "functions", "variables" or "types"
1237 * regexp - The regular expression to look for.
1246 gdb_search (clientData
, interp
, objc
, objv
)
1247 ClientData clientData
;
1250 Tcl_Obj
*CONST objv
[];
1252 struct symbol_search
*ss
= NULL
;
1253 struct symbol_search
*p
;
1254 struct cleanup
*old_chain
= NULL
;
1255 Tcl_Obj
*CONST
*switch_objv
;
1256 int index
, switch_objc
, i
;
1257 namespace_enum space
= 0;
1259 int static_only
, nfiles
;
1260 Tcl_Obj
**file_list
;
1262 static char *search_options
[] = { "functions", "variables", "types", (char *) NULL
};
1263 static char *switches
[] = { "-files", "-static", (char *) NULL
};
1264 enum search_opts
{ SEARCH_FUNCTIONS
, SEARCH_VARIABLES
, SEARCH_TYPES
};
1265 enum switches_opts
{ SWITCH_FILES
, SWITCH_STATIC_ONLY
};
1269 Tcl_WrongNumArgs (interp
, 1, objv
, "option regexp ?arg ...?");
1270 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1274 if (Tcl_GetIndexFromObj (interp
, objv
[1], search_options
, "option", 0,
1277 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1281 /* Unfortunately, we cannot teach search_symbols to search on
1282 multiple regexps, so we have to do a two-tier search for
1283 any searches which choose to narrow the playing field. */
1284 switch ((enum search_opts
) index
)
1286 case SEARCH_FUNCTIONS
:
1287 space
= FUNCTIONS_NAMESPACE
; break;
1288 case SEARCH_VARIABLES
:
1289 space
= VARIABLES_NAMESPACE
; break;
1291 space
= TYPES_NAMESPACE
; break;
1294 regexp
= Tcl_GetStringFromObj (objv
[2], NULL
);
1295 /* Process any switches that refine the search */
1296 switch_objc
= objc
- 3;
1297 switch_objv
= objv
+ 3;
1301 files
= (char **) NULL
;
1302 while (switch_objc
> 0)
1304 if (Tcl_GetIndexFromObj (interp
, switch_objv
[0], switches
,
1305 "option", 0, &index
) != TCL_OK
)
1307 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1311 switch ((enum switches_opts
) index
)
1316 if (switch_objc
< 2)
1318 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList -static 1|0]");
1319 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1322 result
= Tcl_ListObjGetElements (interp
, switch_objv
[1], &nfiles
, &file_list
);
1323 if (result
!= TCL_OK
)
1326 files
= (char **) xmalloc (nfiles
* sizeof (char *));
1327 for (i
= 0; i
< nfiles
; i
++)
1328 files
[i
] = Tcl_GetStringFromObj (file_list
[i
], NULL
);
1333 case SWITCH_STATIC_ONLY
:
1334 if (switch_objc
< 2)
1336 Tcl_WrongNumArgs (interp
, 2, objv
, "[-files fileList] [-static 1|0]");
1337 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1340 if ( Tcl_GetBooleanFromObj (interp
, switch_objv
[1], &static_only
) !=
1342 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1352 search_symbols (regexp
, space
, nfiles
, files
, &ss
);
1354 old_chain
= make_cleanup (free_search_symbols
, ss
);
1356 Tcl_SetListObj(result_ptr
->obj_ptr
, 0, NULL
);
1358 for (p
= ss
; p
!= NULL
; p
= p
->next
)
1362 if (static_only
&& p
->block
!= STATIC_BLOCK
)
1365 elem
= Tcl_NewListObj (0, NULL
);
1367 if (p
->msymbol
== NULL
)
1368 Tcl_ListObjAppendElement (interp
, elem
,
1369 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->symbol
), -1));
1371 Tcl_ListObjAppendElement (interp
, elem
,
1372 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p
->msymbol
), -1));
1374 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, elem
);
1378 do_cleanups (old_chain
);
1383 /* This implements the tcl command gdb_listfuncs
1385 * It lists all the functions defined in a given file
1388 * file - the file to look in
1390 * A list of two element lists, the first element is
1391 * the symbol name, and the second is a boolean indicating
1392 * whether the symbol is demangled (1 for yes).
1396 gdb_listfuncs (clientData
, interp
, objc
, objv
)
1397 ClientData clientData
;
1400 Tcl_Obj
*CONST objv
[];
1402 struct symtab
*symtab
;
1403 struct blockvector
*bv
;
1407 Tcl_Obj
*funcVals
[2];
1411 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1414 symtab
= full_lookup_symtab (Tcl_GetStringFromObj (objv
[1], NULL
));
1417 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No such file", -1);
1421 if (mangled
== NULL
)
1423 mangled
= Tcl_NewBooleanObj(1);
1424 not_mangled
= Tcl_NewBooleanObj(0);
1425 Tcl_IncrRefCount(mangled
);
1426 Tcl_IncrRefCount(not_mangled
);
1429 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1431 bv
= BLOCKVECTOR (symtab
);
1432 for (i
= GLOBAL_BLOCK
; i
<= STATIC_BLOCK
; i
++)
1434 b
= BLOCKVECTOR_BLOCK (bv
, i
);
1435 /* Skip the sort if this block is always sorted. */
1436 if (!BLOCK_SHOULD_SORT (b
))
1437 sort_block_syms (b
);
1438 for (j
= 0; j
< BLOCK_NSYMS (b
); j
++)
1440 sym
= BLOCK_SYM (b
, j
);
1441 if (SYMBOL_CLASS (sym
) == LOC_BLOCK
)
1444 char *name
= cplus_demangle (SYMBOL_NAME(sym
), 0);
1447 funcVals
[0] = Tcl_NewStringObj(name
, -1);
1448 funcVals
[1] = mangled
;
1452 funcVals
[0] = Tcl_NewStringObj(SYMBOL_NAME(sym
), -1);
1453 funcVals
[1] = not_mangled
;
1455 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1456 Tcl_NewListObj (2, funcVals
));
1465 * This section contains all the commands that act on the registers:
1468 /* This is a sort of mapcar function for operations on registers */
1471 map_arg_registers (objc
, objv
, func
, argp
)
1473 Tcl_Obj
*CONST objv
[];
1474 void (*func
) PARAMS ((int regnum
, void *argp
));
1479 /* Note that the test for a valid register must include checking the
1480 reg_names array because NUM_REGS may be allocated for the union of the
1481 register sets within a family of related processors. In this case, the
1482 trailing entries of reg_names will change depending upon the particular
1483 processor being debugged. */
1485 if (objc
== 0) /* No args, just do all the regs */
1489 && reg_names
[regnum
] != NULL
1490 && *reg_names
[regnum
] != '\000';
1492 func (regnum
, argp
);
1497 /* Else, list of register #s, just do listed regs */
1498 for (; objc
> 0; objc
--, objv
++)
1501 if (Tcl_GetIntFromObj (NULL
, *objv
, ®num
) != TCL_OK
) {
1502 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1507 && regnum
< NUM_REGS
1508 && reg_names
[regnum
] != NULL
1509 && *reg_names
[regnum
] != '\000')
1510 func (regnum
, argp
);
1513 Tcl_SetStringObj (result_ptr
->obj_ptr
, "bad register number", -1);
1521 /* This implements the TCL command `gdb_regnames', which returns a list of
1522 all of the register names. */
1525 gdb_regnames (clientData
, interp
, objc
, objv
)
1526 ClientData clientData
;
1529 Tcl_Obj
*CONST objv
[];
1534 return map_arg_registers (objc
, objv
, get_register_name
, NULL
);
1538 get_register_name (regnum
, argp
)
1540 void *argp
; /* Ignored */
1542 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1543 Tcl_NewStringObj (reg_names
[regnum
], -1));
1546 /* This implements the tcl command gdb_fetch_registers
1547 * Pass it a list of register names, and it will
1548 * return their values as a list.
1551 * format: The format string for printing the values
1552 * args: the registers to look for
1554 * A list of their values.
1558 gdb_fetch_registers (clientData
, interp
, objc
, objv
)
1559 ClientData clientData
;
1562 Tcl_Obj
*CONST objv
[];
1568 Tcl_SetStringObj (result_ptr
->obj_ptr
,
1569 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
1573 format
= *(Tcl_GetStringFromObj(objv
[0], NULL
));
1577 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Output the results as a list */
1578 result
= map_arg_registers (objc
, objv
, get_register
, (void *) format
);
1579 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
1585 get_register (regnum
, fp
)
1589 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1590 char virtual_buffer
[MAX_REGISTER_VIRTUAL_SIZE
];
1591 int format
= (int)fp
;
1596 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1598 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
1599 Tcl_NewStringObj ("Optimized out", -1));
1603 /* Convert raw data to virtual format if necessary. */
1605 if (REGISTER_CONVERTIBLE (regnum
))
1607 REGISTER_CONVERT_TO_VIRTUAL (regnum
, REGISTER_VIRTUAL_TYPE (regnum
),
1608 raw_buffer
, virtual_buffer
);
1611 memcpy (virtual_buffer
, raw_buffer
, REGISTER_VIRTUAL_SIZE (regnum
));
1616 printf_filtered ("0x");
1617 for (j
= 0; j
< REGISTER_RAW_SIZE (regnum
); j
++)
1619 register int idx
= TARGET_BYTE_ORDER
== BIG_ENDIAN
? j
1620 : REGISTER_RAW_SIZE (regnum
) - 1 - j
;
1621 printf_filtered ("%02x", (unsigned char)raw_buffer
[idx
]);
1625 val_print (REGISTER_VIRTUAL_TYPE (regnum
), virtual_buffer
, 0,
1626 gdb_stdout
, format
, 1, 0, Val_pretty_default
);
1630 /* This implements the tcl command get_pc_reg
1631 * It returns the value of the PC register
1636 * The value of the pc register.
1640 get_pc_register (clientData
, interp
, objc
, objv
)
1641 ClientData clientData
;
1644 Tcl_Obj
*CONST objv
[];
1648 sprintf (buff
, "0x%llx",(long long) read_register (PC_REGNUM
));
1649 Tcl_SetStringObj(result_ptr
->obj_ptr
, buff
, -1);
1653 /* This implements the tcl command "gdb_changed_register_list"
1654 * It takes a list of registers, and returns a list of
1655 * the registers on that list that have changed since the last
1656 * time the proc was called.
1659 * A list of registers.
1661 * A list of changed registers.
1665 gdb_changed_register_list (clientData
, interp
, objc
, objv
)
1666 ClientData clientData
;
1669 Tcl_Obj
*CONST objv
[];
1674 return map_arg_registers (objc
, objv
, register_changed_p
, NULL
);
1678 register_changed_p (regnum
, argp
)
1680 void *argp
; /* Ignored */
1682 char raw_buffer
[MAX_REGISTER_RAW_SIZE
];
1684 if (read_relative_register_raw_bytes (regnum
, raw_buffer
))
1687 if (memcmp (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1688 REGISTER_RAW_SIZE (regnum
)) == 0)
1691 /* Found a changed register. Save new value and return its number. */
1693 memcpy (&old_regs
[REGISTER_BYTE (regnum
)], raw_buffer
,
1694 REGISTER_RAW_SIZE (regnum
));
1696 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(regnum
));
1700 * This section contains the commands that deal with tracepoints:
1703 /* return a list of all tracepoint numbers in interpreter */
1705 gdb_get_tracepoint_list (clientData
, interp
, objc
, objv
)
1706 ClientData clientData
;
1709 Tcl_Obj
*CONST objv
[];
1711 struct tracepoint
*tp
;
1713 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1715 ALL_TRACEPOINTS (tp
)
1716 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->number
));
1721 /* returns -1 if not found, tracepoint # if found */
1723 tracepoint_exists (char * args
)
1725 struct tracepoint
*tp
;
1727 struct symtabs_and_lines sals
;
1731 sals
= decode_line_1 (&args
, 1, NULL
, 0, &canonical
);
1732 if (sals
.nelts
== 1)
1734 resolve_sal_pc (&sals
.sals
[0]);
1735 file
= xmalloc (strlen (sals
.sals
[0].symtab
->dirname
)
1736 + strlen (sals
.sals
[0].symtab
->filename
) + 1);
1739 strcpy (file
, sals
.sals
[0].symtab
->dirname
);
1740 strcat (file
, sals
.sals
[0].symtab
->filename
);
1742 ALL_TRACEPOINTS (tp
)
1744 if (tp
->address
== sals
.sals
[0].pc
)
1745 result
= tp
->number
;
1747 /* Why is this here? This messes up assembly traces */
1748 else if (tp
->source_file
!= NULL
1749 && strcmp (tp
->source_file
, file
) == 0
1750 && sals
.sals
[0].line
== tp
->line_number
)
1751 result
= tp
->number
;
1762 gdb_tracepoint_exists_command (clientData
, interp
, objc
, objv
)
1763 ClientData clientData
;
1766 Tcl_Obj
*CONST objv
[];
1772 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1773 Tcl_GetStringFromObj (objv
[0], NULL
),
1774 " function:line|function|line|*addr\"", NULL
);
1778 args
= Tcl_GetStringFromObj (objv
[1], NULL
);
1780 Tcl_SetIntObj (result_ptr
->obj_ptr
, tracepoint_exists (args
));
1785 gdb_get_tracepoint_info (clientData
, interp
, objc
, objv
)
1786 ClientData clientData
;
1789 Tcl_Obj
*CONST objv
[];
1791 struct symtab_and_line sal
;
1793 struct tracepoint
*tp
;
1794 struct action_line
*al
;
1795 Tcl_Obj
*action_list
;
1796 char *filename
, *funcname
;
1801 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
1805 if (Tcl_GetIntFromObj (NULL
, objv
[1], &tpnum
) != TCL_OK
)
1807 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
1811 ALL_TRACEPOINTS (tp
)
1812 if (tp
->number
== tpnum
)
1817 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Tracepoint #%d does not exist", -1);
1821 Tcl_SetListObj (result_ptr
->obj_ptr
, 0, NULL
);
1822 sal
= find_pc_line (tp
->address
, 0);
1823 filename
= symtab_to_filename (sal
.symtab
);
1824 if (filename
== NULL
)
1826 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
,
1827 Tcl_NewStringObj (filename
, -1));
1828 find_pc_partial_function (tp
->address
, &funcname
, NULL
, NULL
);
1829 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (funcname
, -1));
1830 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (sal
.line
));
1831 sprintf (tmp
, "0x%lx", tp
->address
);
1832 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewStringObj (tmp
, -1));
1833 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->enabled
));
1834 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->pass_count
));
1835 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->step_count
));
1836 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->thread
));
1837 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, Tcl_NewIntObj (tp
->hit_count
));
1839 /* Append a list of actions */
1840 action_list
= Tcl_NewObj ();
1841 for (al
= tp
->actions
; al
!= NULL
; al
= al
->next
)
1843 Tcl_ListObjAppendElement (interp
, action_list
,
1844 Tcl_NewStringObj (al
->action
, -1));
1846 Tcl_ListObjAppendElement (interp
, result_ptr
->obj_ptr
, action_list
);
1853 gdb_trace_status (clientData
, interp
, objc
, objv
)
1854 ClientData clientData
;
1857 Tcl_Obj
*CONST objv
[];
1861 if (trace_running_p
)
1864 Tcl_SetIntObj (result_ptr
->obj_ptr
, result
);
1871 gdb_get_trace_frame_num (clientData
, interp
, objc
, objv
)
1872 ClientData clientData
;
1875 Tcl_Obj
*CONST objv
[];
1879 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # of args: should be \"",
1880 Tcl_GetStringFromObj (objv
[0], NULL
),
1881 " linespec\"", NULL
);
1885 Tcl_SetIntObj (result_ptr
->obj_ptr
, get_traceframe_number ());
1890 /* This implements the tcl command gdb_actions
1891 * It sets actions for a given tracepoint.
1894 * number: the tracepoint in question
1895 * actions: the actions to add to this tracepoint
1901 gdb_actions_command (clientData
, interp
, objc
, objv
)
1902 ClientData clientData
;
1905 Tcl_Obj
*CONST objv
[];
1907 struct tracepoint
*tp
;
1909 int nactions
, i
, len
;
1910 char *number
, *args
, *action
;
1912 struct action_line
*next
= NULL
, *temp
;
1913 enum actionline_type linetype
;
1917 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "wrong # args: should be: \"",
1918 Tcl_GetStringFromObj (objv
[0], NULL
),
1919 " number actions\"", NULL
);
1923 args
= number
= Tcl_GetStringFromObj (objv
[1], NULL
);
1924 tp
= get_tracepoint_by_number (&args
);
1927 Tcl_AppendStringsToObj (result_ptr
->obj_ptr
, "Tracepoint \"", number
, "\" does not exist", NULL
);
1931 /* Free any existing actions */
1932 if (tp
->actions
!= NULL
)
1937 Tcl_ListObjGetElements (interp
, objv
[2], &nactions
, &actions
);
1939 /* Add the actions to the tracepoint */
1940 for (i
= 0; i
< nactions
; i
++)
1942 temp
= xmalloc (sizeof (struct action_line
));
1944 action
= Tcl_GetStringFromObj (actions
[i
], &len
);
1945 temp
->action
= savestring (action
, len
);
1947 linetype
= validate_actionline (&(temp
->action
), tp
);
1949 if (linetype
== BADLINE
)
1971 * This section has commands that handle source disassembly.
1974 /* This implements the tcl command gdb_disassemble
1977 * source_with_assm - must be "source" or "nosource"
1978 * low_address - the address from which to start disassembly
1979 * ?hi_address? - the address to which to disassemble, defaults
1980 * to the end of the function containing low_address.
1982 * The disassembled code is passed to fputs_unfiltered, so it
1983 * either goes to the console if result_ptr->obj_ptr is NULL or to
1988 gdb_disassemble (clientData
, interp
, objc
, objv
)
1989 ClientData clientData
;
1992 Tcl_Obj
*CONST objv
[];
1994 CORE_ADDR pc
, low
, high
;
1995 int mixed_source_and_assembly
;
1996 static disassemble_info di
;
1997 static int di_initialized
;
2000 if (objc
!= 3 && objc
!= 4)
2001 error ("wrong # args");
2003 if (! di_initialized
)
2005 INIT_DISASSEMBLE_INFO_NO_ARCH (di
, gdb_stdout
,
2006 (fprintf_ftype
) fprintf_unfiltered
);
2007 di
.flavour
= bfd_target_unknown_flavour
;
2008 di
.memory_error_func
= dis_asm_memory_error
;
2009 di
.print_address_func
= dis_asm_print_address
;
2013 di
.mach
= tm_print_insn_info
.mach
;
2014 if (TARGET_BYTE_ORDER
== BIG_ENDIAN
)
2015 di
.endian
= BFD_ENDIAN_BIG
;
2017 di
.endian
= BFD_ENDIAN_LITTLE
;
2019 arg_ptr
= Tcl_GetStringFromObj (objv
[1], NULL
);
2020 if (*arg_ptr
== 's' && strcmp (arg_ptr
, "source") == 0)
2021 mixed_source_and_assembly
= 1;
2022 else if (*arg_ptr
== 'n' && strcmp (arg_ptr
, "nosource") == 0)
2023 mixed_source_and_assembly
= 0;
2025 error ("First arg must be 'source' or 'nosource'");
2027 low
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[2], NULL
));
2031 if (find_pc_partial_function (low
, NULL
, &low
, &high
) == 0)
2032 error ("No function contains specified address");
2035 high
= parse_and_eval_address (Tcl_GetStringFromObj (objv
[3], NULL
));
2037 /* If disassemble_from_exec == -1, then we use the following heuristic to
2038 determine whether or not to do disassembly from target memory or from the
2041 If we're debugging a local process, read target memory, instead of the
2042 exec file. This makes disassembly of functions in shared libs work
2045 Else, we're debugging a remote process, and should disassemble from the
2046 exec file for speed. However, this is no good if the target modifies its
2047 code (for relocation, or whatever).
2050 if (disassemble_from_exec
== -1)
2052 if (strcmp (target_shortname
, "child") == 0
2053 || strcmp (target_shortname
, "procfs") == 0
2054 || strcmp (target_shortname
, "vxprocess") == 0)
2055 disassemble_from_exec
= 0; /* It's a child process, read inferior mem */
2057 disassemble_from_exec
= 1; /* It's remote, read the exec file */
2060 if (disassemble_from_exec
)
2061 di
.read_memory_func
= gdbtk_dis_asm_read_memory
;
2063 di
.read_memory_func
= dis_asm_read_memory
;
2065 /* If just doing straight assembly, all we need to do is disassemble
2066 everything between low and high. If doing mixed source/assembly, we've
2067 got a totally different path to follow. */
2069 if (mixed_source_and_assembly
)
2070 { /* Come here for mixed source/assembly */
2071 /* The idea here is to present a source-O-centric view of a function to
2072 the user. This means that things are presented in source order, with
2073 (possibly) out of order assembly immediately following. */
2074 struct symtab
*symtab
;
2075 struct linetable_entry
*le
;
2078 struct my_line_entry
*mle
;
2079 struct symtab_and_line sal
;
2084 symtab
= find_pc_symtab (low
); /* Assume symtab is valid for whole PC range */
2089 /* First, convert the linetable to a bunch of my_line_entry's. */
2091 le
= symtab
->linetable
->item
;
2092 nlines
= symtab
->linetable
->nitems
;
2097 mle
= (struct my_line_entry
*) alloca (nlines
* sizeof (struct my_line_entry
));
2101 /* Copy linetable entries for this function into our data structure, creating
2102 end_pc's and setting out_of_order as appropriate. */
2104 /* First, skip all the preceding functions. */
2106 for (i
= 0; i
< nlines
- 1 && le
[i
].pc
< low
; i
++) ;
2108 /* Now, copy all entries before the end of this function. */
2111 for (; i
< nlines
- 1 && le
[i
].pc
< high
; i
++)
2113 if (le
[i
].line
== le
[i
+ 1].line
2114 && le
[i
].pc
== le
[i
+ 1].pc
)
2115 continue; /* Ignore duplicates */
2117 mle
[newlines
].line
= le
[i
].line
;
2118 if (le
[i
].line
> le
[i
+ 1].line
)
2120 mle
[newlines
].start_pc
= le
[i
].pc
;
2121 mle
[newlines
].end_pc
= le
[i
+ 1].pc
;
2125 /* If we're on the last line, and it's part of the function, then we need to
2126 get the end pc in a special way. */
2131 mle
[newlines
].line
= le
[i
].line
;
2132 mle
[newlines
].start_pc
= le
[i
].pc
;
2133 sal
= find_pc_line (le
[i
].pc
, 0);
2134 mle
[newlines
].end_pc
= sal
.end
;
2138 /* Now, sort mle by line #s (and, then by addresses within lines). */
2141 qsort (mle
, newlines
, sizeof (struct my_line_entry
), compare_lines
);
2143 /* Now, for each line entry, emit the specified lines (unless they have been
2144 emitted before), followed by the assembly code for that line. */
2146 next_line
= 0; /* Force out first line */
2147 for (i
= 0; i
< newlines
; i
++)
2149 /* Print out everything from next_line to the current line. */
2151 if (mle
[i
].line
>= next_line
)
2154 print_source_lines (symtab
, next_line
, mle
[i
].line
+ 1, 0);
2156 print_source_lines (symtab
, mle
[i
].line
, mle
[i
].line
+ 1, 0);
2158 next_line
= mle
[i
].line
+ 1;
2161 for (pc
= mle
[i
].start_pc
; pc
< mle
[i
].end_pc
; )
2164 fputs_unfiltered (" ", gdb_stdout
);
2165 print_address (pc
, gdb_stdout
);
2166 fputs_unfiltered (":\t ", gdb_stdout
);
2167 pc
+= (*tm_print_insn
) (pc
, &di
);
2168 fputs_unfiltered ("\n", gdb_stdout
);
2175 for (pc
= low
; pc
< high
; )
2178 fputs_unfiltered (" ", gdb_stdout
);
2179 print_address (pc
, gdb_stdout
);
2180 fputs_unfiltered (":\t ", gdb_stdout
);
2181 pc
+= (*tm_print_insn
) (pc
, &di
);
2182 fputs_unfiltered ("\n", gdb_stdout
);
2186 gdb_flush (gdb_stdout
);
2191 /* This is the memory_read_func for gdb_disassemble when we are
2192 disassembling from the exec file. */
2195 gdbtk_dis_asm_read_memory (memaddr
, myaddr
, len
, info
)
2199 disassemble_info
*info
;
2201 extern struct target_ops exec_ops
;
2205 res
= xfer_memory (memaddr
, myaddr
, len
, 0, &exec_ops
);
2216 /* This will be passed to qsort to sort the results of the disassembly */
2219 compare_lines (mle1p
, mle2p
)
2223 struct my_line_entry
*mle1
, *mle2
;
2226 mle1
= (struct my_line_entry
*) mle1p
;
2227 mle2
= (struct my_line_entry
*) mle2p
;
2229 val
= mle1
->line
- mle2
->line
;
2234 return mle1
->start_pc
- mle2
->start_pc
;
2237 /* This implements the TCL command `gdb_loc',
2240 * ?symbol? The symbol or address to locate - defaults to pc
2242 * a list consisting of the following:
2243 * basename, function name, filename, line number, address, current pc
2247 gdb_loc (clientData
, interp
, objc
, objv
)
2248 ClientData clientData
;
2251 Tcl_Obj
*CONST objv
[];
2254 struct symtab_and_line sal
;
2255 char *funcname
, *fname
;
2258 if (!have_full_symbols () && !have_partial_symbols ())
2260 Tcl_SetStringObj (result_ptr
->obj_ptr
, "No symbol table is loaded", -1);
2266 if (selected_frame
&& (selected_frame
->pc
!= stop_pc
))
2268 /* Note - this next line is not correct on all architectures. */
2269 /* For a graphical debugger we really want to highlight the */
2270 /* assembly line that called the next function on the stack. */
2271 /* Many architectures have the next instruction saved as the */
2272 /* pc on the stack, so what happens is the next instruction is hughlighted. */
2274 pc
= selected_frame
->pc
;
2275 sal
= find_pc_line (selected_frame
->pc
,
2276 selected_frame
->next
!= NULL
2277 && !selected_frame
->next
->signal_handler_caller
2278 && !frame_in_dummy (selected_frame
->next
));
2283 sal
= find_pc_line (stop_pc
, 0);
2288 struct symtabs_and_lines sals
;
2291 sals
= decode_line_spec (Tcl_GetStringFromObj (objv
[1], NULL
), 1);
2297 if (sals
.nelts
!= 1)
2299 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Ambiguous line spec", -1);
2306 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong # args", -1);
2311 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2312 Tcl_NewStringObj (sal
.symtab
->filename
, -1));
2314 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewStringObj ("", 0));
2316 find_pc_partial_function (pc
, &funcname
, NULL
, NULL
);
2317 fname
= cplus_demangle (funcname
, 0);
2320 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2321 Tcl_NewStringObj (fname
, -1));
2325 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2326 Tcl_NewStringObj (funcname
, -1));
2328 filename
= symtab_to_filename (sal
.symtab
);
2329 if (filename
== NULL
)
2332 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2333 Tcl_NewStringObj (filename
, -1));
2334 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj(sal
.line
)); /* line number */
2335 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(pc
)); /* PC in current frame */
2336 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%s", paddr_nz(stop_pc
)); /* Real PC */
2340 /* This implements the Tcl command 'gdb_get_mem', which
2341 * dumps a block of memory
2343 * gdb_get_mem addr form size num aschar
2345 * addr: address of data to dump
2346 * form: a char indicating format
2347 * size: size of each element; 1,2,4, or 8 bytes
2348 * num: the number of bytes to read
2349 * acshar: an optional ascii character to use in ASCII dump
2352 * a list of elements followed by an optional ASCII dump
2356 gdb_get_mem (clientData
, interp
, objc
, objv
)
2357 ClientData clientData
;
2360 Tcl_Obj
*CONST objv
[];
2362 int size
, asize
, i
, j
, bc
;
2364 int nbytes
, rnum
, bpr
;
2366 char format
, c
, buff
[128], aschar
, *mbuf
, *mptr
, *cptr
, *bptr
;
2367 struct type
*val_type
;
2369 if (objc
< 6 || objc
> 7)
2371 Tcl_SetStringObj (result_ptr
->obj_ptr
,
2372 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2376 if (Tcl_GetIntFromObj (interp
, objv
[3], &size
) != TCL_OK
)
2378 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2383 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid size, must be > 0", -1);
2387 if (Tcl_GetIntFromObj (interp
, objv
[4], &nbytes
) != TCL_OK
)
2389 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2394 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid number of bytes, must be > 0",
2399 if (Tcl_GetIntFromObj (interp
, objv
[5], &bpr
) != TCL_OK
)
2401 result_ptr
->flags
|= GDBTK_IN_TCL_RESULT
;
2406 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Invalid bytes per row, must be > 0", -1);
2410 if (Tcl_GetLongFromObj (interp
, objv
[1], &tmp
) != TCL_OK
)
2413 addr
= (CORE_ADDR
) tmp
;
2415 format
= *(Tcl_GetStringFromObj (objv
[2], NULL
));
2416 mbuf
= (char *)malloc (nbytes
+32);
2419 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Out of memory.", -1);
2423 memset (mbuf
, 0, nbytes
+32);
2426 rnum
= target_read_memory_partial (addr
, mbuf
, nbytes
, NULL
);
2429 aschar
= *(Tcl_GetStringFromObj(objv
[6], NULL
));
2435 val_type
= builtin_type_char
;
2439 val_type
= builtin_type_short
;
2443 val_type
= builtin_type_int
;
2447 val_type
= builtin_type_long_long
;
2451 val_type
= builtin_type_char
;
2455 bc
= 0; /* count of bytes in a row */
2456 buff
[0] = '"'; /* buffer for ascii dump */
2457 bptr
= &buff
[1]; /* pointer for ascii dump */
2459 result_ptr
->flags
|= GDBTK_MAKES_LIST
; /* Build up the result as a list... */
2461 for (i
=0; i
< nbytes
; i
+= size
)
2465 fputs_unfiltered ("N/A ", gdb_stdout
);
2467 for ( j
= 0; j
< size
; j
++)
2472 print_scalar_formatted (mptr
, val_type
, format
, asize
, gdb_stdout
);
2476 for ( j
= 0; j
< size
; j
++)
2479 if (c
< 32 || c
> 126)
2491 if (aschar
&& (bc
>= bpr
))
2493 /* end of row. print it and reset variables */
2498 fputs_unfiltered (buff
, gdb_stdout
);
2503 result_ptr
->flags
&= ~GDBTK_MAKES_LIST
;
2511 /* This implements the tcl command "gdb_loadfile"
2512 * It loads a c source file into a text widget.
2515 * widget: the name of the text widget to fill
2516 * filename: the name of the file to load
2517 * linenumbers: A boolean indicating whether or not to display line numbers.
2522 /* In this routine, we will build up a "line table", i.e. a
2523 * table of bits showing which lines in the source file are executible.
2524 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2526 * Its size limits the maximum number of lines
2527 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2528 * the file is loaded, so it is OK to make this very large.
2529 * Additional memory will be allocated if needed. */
2530 #define LTABLE_SIZE 20000
2532 gdb_loadfile (clientData
, interp
, objc
, objv
)
2533 ClientData clientData
;
2536 Tcl_Obj
*CONST objv
[];
2538 char *file
, *widget
;
2539 int linenumbers
, ln
, lnum
, ltable_size
;
2542 struct symtab
*symtab
;
2543 struct linetable_entry
*le
;
2546 Tcl_DString text_cmd_1
, text_cmd_2
, *cur_cmd
;
2547 char line
[1024], line_num_buf
[16];
2548 int prefix_len_1
, prefix_len_2
, cur_prefix_len
, widget_len
;
2553 Tcl_WrongNumArgs(interp
, 1, objv
, "widget filename linenumbers");
2557 widget
= Tcl_GetStringFromObj (objv
[1], NULL
);
2558 if ( Tk_NameToWindow (interp
, widget
, Tk_MainWindow (interp
)) == NULL
)
2563 file
= Tcl_GetStringFromObj (objv
[2], NULL
);
2564 Tcl_GetBooleanFromObj (interp
, objv
[3], &linenumbers
);
2566 if ((fp
= fopen ( file
, "r" )) == NULL
)
2568 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Can't open file for reading", -1);
2572 symtab
= full_lookup_symtab (file
);
2575 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "File not found in symtab", -1);
2580 if (stat (file
, &st
) < 0)
2582 catch_errors (perror_with_name_wrapper
, "gdbtk: get time stamp", "",
2587 if (symtab
&& symtab
->objfile
&& symtab
->objfile
->obfd
)
2588 mtime
= bfd_get_mtime(symtab
->objfile
->obfd
);
2590 mtime
= bfd_get_mtime(exec_bfd
);
2592 if (mtime
&& mtime
< st
.st_mtime
)
2593 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2596 /* Source linenumbers don't appear to be in order, and a sort is */
2597 /* too slow so the fastest solution is just to allocate a huge */
2598 /* array and set the array entry for each linenumber */
2600 ltable_size
= LTABLE_SIZE
;
2601 ltable
= (char *)malloc (LTABLE_SIZE
);
2604 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2609 memset (ltable
, 0, LTABLE_SIZE
);
2611 if (symtab
->linetable
&& symtab
->linetable
->nitems
)
2613 le
= symtab
->linetable
->item
;
2614 for (ln
= symtab
->linetable
->nitems
;ln
> 0; ln
--, le
++)
2616 lnum
= le
->line
>> 3;
2617 if (lnum
>= ltable_size
)
2620 new_ltable
= (char *)realloc (ltable
, ltable_size
*2);
2621 memset (new_ltable
+ ltable_size
, 0, ltable_size
);
2623 if (new_ltable
== NULL
)
2625 Tcl_SetStringObj ( result_ptr
->obj_ptr
, "Out of memory.", -1);
2630 ltable
= new_ltable
;
2632 ltable
[lnum
] |= 1 << (le
->line
% 8);
2636 Tcl_DStringInit(&text_cmd_1
);
2637 Tcl_DStringInit(&text_cmd_2
);
2641 widget_len
= strlen (widget
);
2644 Tcl_DStringAppend (&text_cmd_1
, widget
, widget_len
);
2645 Tcl_DStringAppend (&text_cmd_2
, widget
, widget_len
);
2649 Tcl_DStringAppend (&text_cmd_1
, " insert end {-\t", -1);
2650 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2652 Tcl_DStringAppend (&text_cmd_2
, " insert end { \t", -1);
2653 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2655 while (fgets (line
+ 1, 980, fp
))
2657 sprintf (line_num_buf
, "%d", ln
);
2658 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2660 cur_cmd
= &text_cmd_1
;
2661 cur_prefix_len
= prefix_len_1
;
2662 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2663 Tcl_DStringAppend (cur_cmd
, "} break_tag", 11);
2667 cur_cmd
= &text_cmd_2
;
2668 cur_prefix_len
= prefix_len_2
;
2669 Tcl_DStringAppend (cur_cmd
, line_num_buf
, -1);
2670 Tcl_DStringAppend (cur_cmd
, "} \"\"", 4);
2673 Tcl_DStringAppendElement (cur_cmd
, line
);
2674 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2676 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2677 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2683 Tcl_DStringAppend (&text_cmd_1
, " insert end {- } break_tag", -1);
2684 prefix_len_1
= Tcl_DStringLength(&text_cmd_1
);
2685 Tcl_DStringAppend (&text_cmd_2
, " insert end { } \"\"", -1);
2686 prefix_len_2
= Tcl_DStringLength(&text_cmd_2
);
2689 while (fgets (line
+ 1, 980, fp
))
2691 if (ltable
[ln
>> 3] & (1 << (ln
% 8)))
2693 cur_cmd
= &text_cmd_1
;
2694 cur_prefix_len
= prefix_len_1
;
2698 cur_cmd
= &text_cmd_2
;
2699 cur_prefix_len
= prefix_len_2
;
2702 Tcl_DStringAppendElement (cur_cmd
, line
);
2703 Tcl_DStringAppend (cur_cmd
, " source_tag", 11);
2705 Tcl_Eval(interp
, Tcl_DStringValue(cur_cmd
));
2706 Tcl_DStringSetLength(cur_cmd
, cur_prefix_len
);
2712 Tcl_DStringFree (&text_cmd_1
);
2713 Tcl_DStringFree (&text_cmd_2
);
2720 * This section contains commands for manipulation of breakpoints.
2724 /* set a breakpoint by source file and line number */
2725 /* flags are as follows: */
2726 /* least significant 2 bits are disposition, rest is */
2727 /* type (normally 0).
2730 bp_breakpoint, Normal breakpoint
2731 bp_hardware_breakpoint, Hardware assisted breakpoint
2734 Disposition of breakpoint. Ie: what to do after hitting it.
2737 del_at_next_stop, Delete at next stop, whether hit or not
2739 donttouch Leave it alone
2743 /* This implements the tcl command "gdb_set_bp"
2744 * It sets breakpoints, and runs the Tcl command
2745 * gdbtk_tcl_breakpoint create
2746 * to register the new breakpoint with the GUI.
2749 * filename: the file in which to set the breakpoint
2750 * line: the line number for the breakpoint
2751 * type: the type of the breakpoint
2753 * The return value of the call to gdbtk_tcl_breakpoint.
2757 gdb_set_bp (clientData
, interp
, objc
, objv
)
2758 ClientData clientData
;
2761 Tcl_Obj
*CONST objv
[];
2764 struct symtab_and_line sal
;
2765 int line
, flags
, ret
;
2766 struct breakpoint
*b
;
2772 Tcl_WrongNumArgs(interp
, 1, objv
, "filename line type");
2776 sal
.symtab
= full_lookup_symtab (Tcl_GetStringFromObj( objv
[1], NULL
));
2777 if (sal
.symtab
== NULL
)
2780 if (Tcl_GetIntFromObj( interp
, objv
[2], &line
) == TCL_ERROR
)
2782 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2786 if (Tcl_GetIntFromObj( interp
, objv
[3], &flags
) == TCL_ERROR
)
2788 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2793 if (!find_line_pc (sal
.symtab
, sal
.line
, &sal
.pc
))
2796 sal
.section
= find_pc_overlay (sal
.pc
);
2797 b
= set_raw_breakpoint (sal
);
2798 set_breakpoint_count (breakpoint_count
+ 1);
2799 b
->number
= breakpoint_count
;
2800 b
->type
= flags
>> 2;
2801 b
->disposition
= flags
& 3;
2803 /* FIXME: this won't work for duplicate basenames! */
2804 sprintf (buf
, "%s:%d", basename (Tcl_GetStringFromObj ( objv
[1], NULL
)), line
);
2805 b
->addr_string
= strsave (buf
);
2807 /* now send notification command back to GUI */
2809 Tcl_DStringInit (&cmd
);
2811 Tcl_DStringAppend (&cmd
, "gdbtk_tcl_breakpoint create ", -1);
2812 sprintf (buf
, "%d", b
->number
);
2813 Tcl_DStringAppendElement(&cmd
, buf
);
2814 sprintf (buf
, "0x%lx", (long)sal
.pc
);
2815 Tcl_DStringAppendElement (&cmd
, buf
);
2816 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[2], NULL
));
2817 Tcl_DStringAppendElement (&cmd
, Tcl_GetStringFromObj (objv
[1], NULL
));
2819 ret
= Tcl_Eval (interp
, Tcl_DStringValue (&cmd
));
2820 Tcl_DStringFree (&cmd
);
2824 /* This implements the tcl command gdb_get_breakpoint_info
2830 * A list with {file, function, line_number, address, type, enabled?,
2831 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
2835 gdb_get_breakpoint_info (clientData
, interp
, objc
, objv
)
2836 ClientData clientData
;
2839 Tcl_Obj
*CONST objv
[];
2841 struct symtab_and_line sal
;
2842 static char *bptypes
[] = {"breakpoint", "hardware breakpoint", "until",
2843 "finish", "watchpoint", "hardware watchpoint",
2844 "read watchpoint", "access watchpoint",
2845 "longjmp", "longjmp resume", "step resume",
2846 "through sigtramp", "watchpoint scope",
2848 static char *bpdisp
[] = {"delete", "delstop", "disable", "donttouch"};
2849 struct command_line
*cmd
;
2851 struct breakpoint
*b
;
2852 extern struct breakpoint
*breakpoint_chain
;
2853 char *funcname
, *fname
, *filename
;
2858 Tcl_SetStringObj (result_ptr
->obj_ptr
, "wrong number of args, should be \"breakpoint\"", -1);
2862 if ( Tcl_GetIntFromObj(NULL
, objv
[1], &bpnum
) != TCL_OK
)
2864 result_ptr
->flags
= GDBTK_IN_TCL_RESULT
;
2868 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2869 if (b
->number
== bpnum
)
2872 if (!b
|| b
->type
!= bp_breakpoint
)
2874 Tcl_SetStringObj (result_ptr
->obj_ptr
, "Breakpoint #%d does not exist", -1);
2878 sal
= find_pc_line (b
->address
, 0);
2880 filename
= symtab_to_filename (sal
.symtab
);
2881 if (filename
== NULL
)
2884 Tcl_SetListObj (result_ptr
->obj_ptr
,0 ,NULL
);
2885 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2886 Tcl_NewStringObj (filename
, -1));
2888 find_pc_partial_function (b
->address
, &funcname
, NULL
, NULL
);
2889 fname
= cplus_demangle (funcname
, 0);
2892 new_obj
= Tcl_NewStringObj (fname
, -1);
2896 new_obj
= Tcl_NewStringObj (funcname
, -1);
2898 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2900 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->line_number
));
2901 sprintf_append_element_to_obj (result_ptr
->obj_ptr
, "0x%lx", b
->address
);
2902 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2903 Tcl_NewStringObj (bptypes
[b
->type
], -1));
2904 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewBooleanObj(b
->enable
== enabled
));
2905 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2906 Tcl_NewStringObj (bpdisp
[b
->disposition
], -1));
2907 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->ignore_count
));
2909 new_obj
= Tcl_NewObj();
2910 for (cmd
= b
->commands
; cmd
; cmd
= cmd
->next
)
2911 Tcl_ListObjAppendElement (NULL
, new_obj
,
2912 Tcl_NewStringObj (cmd
->line
, -1));
2913 Tcl_ListObjAppendElement(NULL
, result_ptr
->obj_ptr
, new_obj
);
2915 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
,
2916 Tcl_NewStringObj (b
->cond_string
, -1));
2918 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->thread
));
2919 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, Tcl_NewIntObj (b
->hit_count
));
2925 /* This implements the tcl command gdb_get_breakpoint_list
2926 * It builds up a list of the current breakpoints.
2931 * A list of breakpoint numbers.
2935 gdb_get_breakpoint_list (clientData
, interp
, objc
, objv
)
2936 ClientData clientData
;
2939 Tcl_Obj
*CONST objv
[];
2941 struct breakpoint
*b
;
2942 extern struct breakpoint
*breakpoint_chain
;
2946 error ("wrong number of args, none are allowed");
2948 for (b
= breakpoint_chain
; b
; b
= b
->next
)
2949 if (b
->type
== bp_breakpoint
)
2951 new_obj
= Tcl_NewIntObj (b
->number
);
2952 Tcl_ListObjAppendElement (NULL
, result_ptr
->obj_ptr
, new_obj
);
2960 * This section contains a bunch of miscellaneous utility commands
2963 /* This implements the tcl command gdb_path_conv
2965 * On Windows, it canonicalizes the pathname,
2966 * On Unix, it is a no op.
2971 * The canonicalized path.
2975 gdb_path_conv (clientData
, interp
, objc
, objv
)
2976 ClientData clientData
;
2979 Tcl_Obj
*CONST objv
[];
2982 error ("wrong # args");
2986 char pathname
[256], *ptr
;
2988 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj(objv
[1], NULL
), pathname
);
2989 for (ptr
= pathname
; *ptr
; ptr
++)
2994 Tcl_SetStringObj (result_ptr
->obj_ptr
, pathname
, -1);
2997 Tcl_SetStringObj (result_ptr
->obj_ptr
, Tcl_GetStringFromObj (objv
[1], NULL
), -1);
3004 * This section has utility routines that are not Tcl commands.
3008 perror_with_name_wrapper (args
)
3011 perror_with_name (args
);
3015 /* The lookup_symtab() in symtab.c doesn't work correctly */
3016 /* It will not work will full pathnames and if multiple */
3017 /* source files have the same basename, it will return */
3018 /* the first one instead of the correct one. This version */
3019 /* also always makes sure symtab->fullname is set. */
3021 static struct symtab
*
3022 full_lookup_symtab(file
)
3026 struct objfile
*objfile
;
3027 char *bfile
, *fullname
;
3028 struct partial_symtab
*pt
;
3033 /* first try a direct lookup */
3034 st
= lookup_symtab (file
);
3038 symtab_to_filename(st
);
3042 /* if the direct approach failed, try */
3043 /* looking up the basename and checking */
3044 /* all matches with the fullname */
3045 bfile
= basename (file
);
3046 ALL_SYMTABS (objfile
, st
)
3048 if (!strcmp (bfile
, basename(st
->filename
)))
3051 fullname
= symtab_to_filename (st
);
3053 fullname
= st
->fullname
;
3055 if (!strcmp (file
, fullname
))
3060 /* still no luck? look at psymtabs */
3061 ALL_PSYMTABS (objfile
, pt
)
3063 if (!strcmp (bfile
, basename(pt
->filename
)))
3065 st
= PSYMTAB_TO_SYMTAB (pt
);
3068 fullname
= symtab_to_filename (st
);
3069 if (!strcmp (file
, fullname
))