projects / deliverable / binutils-gdb.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
1998-12-14 J.T. Conklin <jtc@redbacknetworks.com>
[deliverable/binutils-gdb.git] / gdb / gdbtk-cmds.c
CommitLineData
ca4e7e14
JI		 1/* Tcl/Tk command definitions for gdbtk.
2 Copyright 1994, 1995, 1996, 1997, 1998 Free Software Foundation, Inc.
3
4 Written by Stu Grossman <grossman@cygnus.com> of Cygnus Support.
5
6This file is part of GDB.
7
8This program is free software; you can redistribute it and/or modify
9it under the terms of the GNU General Public License as published by
10the Free Software Foundation; either version 2 of the License, or
11(at your option) any later version.
12
13This program is distributed in the hope that it will be useful,
14but WITHOUT ANY WARRANTY; without even the implied warranty of
15MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16GNU General Public License for more details.
17
18You should have received a copy of the GNU General Public License
19along with this program; if not, write to the Free Software
20Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. */
21
22#include "defs.h"
23#include "symtab.h"
24#include "inferior.h"
25#include "command.h"
26#include "bfd.h"
27#include "symfile.h"
28#include "objfiles.h"
29#include "target.h"
30#include "gdbcore.h"
31#include "tracepoint.h"
32#include "demangle.h"
33
34#ifdef _WIN32
35#include <winuser.h>
36#endif
37
38#include <sys/stat.h>
39
40#include <tcl.h>
41#include <tk.h>
42#include <itcl.h>
43#include <tix.h>
44#include "guitcl.h"
45#include "gdbtk.h"
46
47#ifdef IDE
48/* start-sanitize-ide */
49#include "event.h"
50#include "idetcl.h"
51#include "ilutk.h"
52/* end-sanitize-ide */
53#endif
54
55#ifdef ANSI_PROTOTYPES
56#include <stdarg.h>
57#else
58#include <varargs.h>
59#endif
60#include <signal.h>
61#include <fcntl.h>
62#include <unistd.h>
63#include <setjmp.h>
64#include "top.h"
65#include <sys/ioctl.h>
66#include "gdb_string.h"
67#include "dis-asm.h"
68#include <stdio.h>
69#include "gdbcmd.h"
70
71#include "annotate.h"
72#include <sys/time.h>
73
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. */
78
79struct wrapped_call_args
80{
81 Tcl_Interp *interp;
82 Tcl_ObjCmdProc *func;
83 int objc;
84 Tcl_Obj *CONST *objv;
85 int val;
86};
87
88/* These two objects hold boolean true and false,
89 and are shared by all the list objects that gdb_listfuncs
90 returns. */
91
92static Tcl_Obj *mangled, *not_mangled;
93
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 */
96
97int No_Update = 0;
98int load_in_progress = 0;
99
100/*
101 * This is used in the register fetching routines
102 */
103
104#ifndef REGISTER_CONVERTIBLE
105#define REGISTER_CONVERTIBLE(x) (0 != 0)
106#endif
107
108#ifndef REGISTER_CONVERT_TO_VIRTUAL
109#define REGISTER_CONVERT_TO_VIRTUAL(x, y, z, a)
110#endif
111
112#ifndef INVALID_FLOAT
113#define INVALID_FLOAT(x, y) (0 != 0)
114#endif
115
116
117
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. */
122
123struct my_line_entry {
124 int line;
125 CORE_ADDR start_pc;
126 CORE_ADDR end_pc;
127};
128
129/* This contains the previous values of the registers, since the last call to
130 gdb_changed_register_list. */
131
132static char old_regs[REGISTER_BYTES];
133
63d138d9
JI		 134/* These two lookup tables are used to translate the type & disposition fields
135 of the breakpoint structure (respectively) into something gdbtk understands.
136 They are also used in gdbtk-hooks.c */
137
138char *bptypes[] = {"breakpoint", "hardware breakpoint", "until",
139 "finish", "watchpoint", "hardware watchpoint",
140 "read watchpoint", "access watchpoint",
141 "longjmp", "longjmp resume", "step resume",
142 "through sigtramp", "watchpoint scope",
143 "call dummy" };
144char *bpdisp[] = {"delete", "delstop", "disable", "donttouch"};
145
ca4e7e14
JI		 146/*
147 * These are routines we need from breakpoint.c.
148 * at some point make these static in breakpoint.c and move GUI code there
149 */
150
151extern struct breakpoint *set_raw_breakpoint (struct symtab_and_line sal);
152extern void set_breakpoint_count (int);
153extern int breakpoint_count;
154
2aae6397
JI		 155/* This variable determines where memory used for disassembly is read from.
156 * See note in gdbtk.h for details.
157 */
158int disassemble_from_exec = -1;
159
ca4e7e14
JI		 160
161/*
3d64f1e0 162 * Declarations for routines exported from this file
ca4e7e14
JI		 163 */
164
165int Gdbtk_Init (Tcl_Interp *interp);
3d64f1e0
KS		 166
167/*
168 * Declarations for routines used only in this file.
169 */
170
ca4e7e14
JI		 171static int compare_lines PARAMS ((const PTR, const PTR));
172static int comp_files PARAMS ((const void *, const void *));
173static int call_wrapper PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
174static int gdb_actions_command PARAMS ((ClientData, Tcl_Interp *, int,
175 Tcl_Obj *CONST objv[]));
176static int gdb_changed_register_list PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
177static int gdb_clear_file PARAMS ((ClientData, Tcl_Interp *interp, int, Tcl_Obj *CONST []));
178static int gdb_cmd PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
179static int gdb_confirm_quit PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
180static int gdb_disassemble PARAMS ((ClientData, Tcl_Interp *, int,
181 Tcl_Obj *CONST []));
182static int gdb_eval PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
183static int gdb_fetch_registers PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
184static int gdb_find_file_command PARAMS ((ClientData, Tcl_Interp *, int,
185 Tcl_Obj *CONST objv[]));
186static int gdb_force_quit PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
187static struct symtab *full_lookup_symtab PARAMS ((char *file));
188static int gdb_get_args_command PARAMS ((ClientData, Tcl_Interp *, int,
189 Tcl_Obj *CONST objv[]));
190static int gdb_get_breakpoint_info PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
191static int gdb_get_breakpoint_list PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
192static int gdb_get_file_command PARAMS ((ClientData, Tcl_Interp *, int,
193 Tcl_Obj *CONST objv[]));
194static int gdb_get_function_command PARAMS ((ClientData, Tcl_Interp *, int,
195 Tcl_Obj *CONST objv[]));
196static int gdb_get_line_command PARAMS ((ClientData, Tcl_Interp *, int,
197 Tcl_Obj *CONST objv[]));
198static int gdb_get_locals_command PARAMS ((ClientData, Tcl_Interp *, int,
199 Tcl_Obj *CONST objv[]));
200static int gdb_get_mem PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
201static int gdb_get_trace_frame_num PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
202static int gdb_get_tracepoint_list PARAMS ((ClientData, Tcl_Interp *, int,
203 Tcl_Obj *CONST objv[]));
204static int gdb_get_vars_command PARAMS ((ClientData, Tcl_Interp *, int,
205 Tcl_Obj *CONST objv[]));
206static int gdb_immediate_command PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
207static int gdb_listfiles PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
208static int gdb_listfuncs PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
209static int gdb_loadfile PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
210static int gdb_load_info PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
211static int gdb_loc PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
212static int gdb_path_conv PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
213static int gdb_prompt_command PARAMS ((ClientData, Tcl_Interp *, int,
214 Tcl_Obj *CONST objv[]));
215static int gdb_regnames PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
216static int gdb_search PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST
217 objv[]));
218static int gdb_set_bp PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
23e1f78b 219static int gdb_set_bp_addr PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
d84563bc
MH		 220static int gdb_find_bp_at_line PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
221static int gdb_find_bp_at_addr PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST objv[]));
ca4e7e14
JI		 222static int gdb_stop PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
223static int gdb_target_has_execution_command PARAMS ((ClientData, Tcl_Interp *,
224 int,
225 Tcl_Obj *CONST []));
226static int gdb_trace_status PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
227static int gdb_tracepoint_exists_command PARAMS ((ClientData, Tcl_Interp *,
228 int,
229 Tcl_Obj *CONST objv[]));
230static int gdb_get_tracepoint_info PARAMS ((ClientData, Tcl_Interp *, int,
231 Tcl_Obj *CONST objv[]));
ca4e7e14 232static int gdbtk_dis_asm_read_memory PARAMS ((bfd_vma, bfd_byte *, int, disassemble_info *));
ca4e7e14 233static int get_pc_register PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
3d64f1e0
KS		 234static int gdb_stack PARAMS ((ClientData, Tcl_Interp *, int, Tcl_Obj *CONST []));
235
ca4e7e14
JI		 236char * get_prompt PARAMS ((void));
237static void get_register PARAMS ((int, void *));
238static void get_register_name PARAMS ((int, void *));
239static int map_arg_registers PARAMS ((int, Tcl_Obj *CONST [], void (*) (int, void *), void *));
ca4e7e14
JI		 240static int perror_with_name_wrapper PARAMS ((char *args));
241static void register_changed_p PARAMS ((int, void *));
242void TclDebug PARAMS ((const char *fmt, ...));
243static int wrapped_call (char *opaque_args);
3d64f1e0 244static void get_frame_name PARAMS ((Tcl_Interp *interp, Tcl_Obj *list, struct frame_info *fi));
ca4e7e14
JI		 245\f
246/* Gdbtk_Init
247 * This loads all the Tcl commands into the Tcl interpreter.
248 *
249 * Arguments:
250 * interp - The interpreter into which to load the commands.
251 *
252 * Result:
253 * A standard Tcl result.
254 */
255
256int
257Gdbtk_Init (interp)
258 Tcl_Interp *interp;
259{
260 Tcl_CreateObjCommand (interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL);
261 Tcl_CreateObjCommand (interp, "gdb_immediate", call_wrapper,
262 gdb_immediate_command, NULL);
263 Tcl_CreateObjCommand (interp, "gdb_loc", call_wrapper, gdb_loc, NULL);
264 Tcl_CreateObjCommand (interp, "gdb_path_conv", call_wrapper, gdb_path_conv, NULL);
265 Tcl_CreateObjCommand (interp, "gdb_listfiles", call_wrapper, gdb_listfiles, NULL);
266 Tcl_CreateObjCommand (interp, "gdb_listfuncs", call_wrapper, gdb_listfuncs,
267 NULL);
268 Tcl_CreateObjCommand (interp, "gdb_get_mem", call_wrapper, gdb_get_mem,
269 NULL);
270 Tcl_CreateObjCommand (interp, "gdb_stop", call_wrapper, gdb_stop, NULL);
271 Tcl_CreateObjCommand (interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL);
272 Tcl_CreateObjCommand (interp, "gdb_fetch_registers", call_wrapper,
273 gdb_fetch_registers, NULL);
274 Tcl_CreateObjCommand (interp, "gdb_changed_register_list", call_wrapper,
275 gdb_changed_register_list, NULL);
276 Tcl_CreateObjCommand (interp, "gdb_disassemble", call_wrapper,
277 gdb_disassemble, NULL);
278 Tcl_CreateObjCommand (interp, "gdb_eval", call_wrapper, gdb_eval, NULL);
279 Tcl_CreateObjCommand (interp, "gdb_get_breakpoint_list", call_wrapper,
280 gdb_get_breakpoint_list, NULL);
281 Tcl_CreateObjCommand (interp, "gdb_get_breakpoint_info", call_wrapper,
282 gdb_get_breakpoint_info, NULL);
283 Tcl_CreateObjCommand (interp, "gdb_clear_file", call_wrapper,
284 gdb_clear_file, NULL);
285 Tcl_CreateObjCommand (interp, "gdb_confirm_quit", call_wrapper,
286 gdb_confirm_quit, NULL);
287 Tcl_CreateObjCommand (interp, "gdb_force_quit", call_wrapper,
288 gdb_force_quit, NULL);
289 Tcl_CreateObjCommand (interp, "gdb_target_has_execution",
290 call_wrapper,
291 gdb_target_has_execution_command, NULL);
292 Tcl_CreateObjCommand (interp, "gdb_is_tracing",
293 call_wrapper, gdb_trace_status,
294 NULL);
295 Tcl_CreateObjCommand (interp, "gdb_load_info", call_wrapper, gdb_load_info, NULL);
296 Tcl_CreateObjCommand (interp, "gdb_get_locals", call_wrapper, gdb_get_locals_command,
297 NULL);
298 Tcl_CreateObjCommand (interp, "gdb_get_args", call_wrapper, gdb_get_args_command,
299 NULL);
300 Tcl_CreateObjCommand (interp, "gdb_get_function", call_wrapper, gdb_get_function_command,
301 NULL);
302 Tcl_CreateObjCommand (interp, "gdb_get_line", call_wrapper, gdb_get_line_command,
303 NULL);
304 Tcl_CreateObjCommand (interp, "gdb_get_file", call_wrapper, gdb_get_file_command,
305 NULL);
306 Tcl_CreateObjCommand (interp, "gdb_tracepoint_exists",
307 call_wrapper, gdb_tracepoint_exists_command, NULL);
308 Tcl_CreateObjCommand (interp, "gdb_get_tracepoint_info",
309 call_wrapper, gdb_get_tracepoint_info, NULL);
310 Tcl_CreateObjCommand (interp, "gdb_actions",
311 call_wrapper, gdb_actions_command, NULL);
312 Tcl_CreateObjCommand (interp, "gdb_prompt",
313 call_wrapper, gdb_prompt_command, NULL);
314 Tcl_CreateObjCommand (interp, "gdb_find_file",
315 call_wrapper, gdb_find_file_command, NULL);
316 Tcl_CreateObjCommand (interp, "gdb_get_tracepoint_list",
317 call_wrapper, gdb_get_tracepoint_list, NULL);
318 Tcl_CreateObjCommand (interp, "gdb_pc_reg", call_wrapper, get_pc_register, NULL);
319 Tcl_CreateObjCommand (interp, "gdb_loadfile", call_wrapper, gdb_loadfile, NULL);
320 Tcl_CreateObjCommand (gdbtk_interp, "gdb_search", call_wrapper,
321 gdb_search, NULL);
322 Tcl_CreateObjCommand (interp, "gdb_set_bp", call_wrapper, gdb_set_bp, NULL);
23e1f78b 323 Tcl_CreateObjCommand (interp, "gdb_set_bp_addr", call_wrapper, gdb_set_bp_addr, NULL);
d84563bc
MH		 324 Tcl_CreateObjCommand (interp, "gdb_find_bp_at_line", call_wrapper, gdb_find_bp_at_line, NULL);
325 Tcl_CreateObjCommand (interp, "gdb_find_bp_at_addr", call_wrapper, gdb_find_bp_at_addr, NULL);
ca4e7e14
JI		 326 Tcl_CreateObjCommand (interp, "gdb_get_trace_frame_num",
327 call_wrapper, gdb_get_trace_frame_num, NULL);
3d64f1e0
KS		 328 Tcl_CreateObjCommand (interp, "gdb_stack", call_wrapper, gdb_stack, NULL);
329
4ff5d55a 330 Tcl_LinkVar (interp, "gdb_selected_frame_level",
3d64f1e0
KS		 331 (char *) &selected_frame_level,
332 TCL_LINK_INT | TCL_LINK_READ_ONLY);
ca4e7e14 333
4ff5d55a
MH		 334 /* gdb_context is used for debugging multiple threads or tasks */
335 Tcl_LinkVar (interp, "gdb_context_id",
336 (char *) &gdb_context,
337 TCL_LINK_INT | TCL_LINK_READ_ONLY);
2aae6397
JI		 338
339 /* Determine where to disassemble from */
340 Tcl_LinkVar (gdbtk_interp, "disassemble-from-exec", (char *) &disassemble_from_exec,
341 TCL_LINK_INT);
4ff5d55a 342
ca4e7e14
JI		 343 Tcl_PkgProvide(interp, "Gdbtk", GDBTK_VERSION);
344 return TCL_OK;
345}
346
347/* This routine acts as a top-level for all GDB code called by Tcl/Tk. It
348 handles cleanups, and uses catch_errors to trap calls to return_to_top_level
349 (usually via error).
350 This is necessary in order to prevent a longjmp out of the bowels of Tk,
351 possibly leaving things in a bad state. Since this routine can be called
352 recursively, it needs to save and restore the contents of the result_ptr as
353 necessary. */
354
355static int
356call_wrapper (clientData, interp, objc, objv)
357 ClientData clientData;
358 Tcl_Interp *interp;
359 int objc;
360 Tcl_Obj *CONST objv[];
361{
362 struct wrapped_call_args wrapped_args;
363 gdbtk_result new_result, *old_result_ptr;
ca4e7e14
JI		 364
365 old_result_ptr = result_ptr;
366 result_ptr = &new_result;
367 result_ptr->obj_ptr = Tcl_NewObj();
368 result_ptr->flags = GDBTK_TO_RESULT;
369
370 wrapped_args.func = (Tcl_ObjCmdProc *) clientData;
371 wrapped_args.interp = interp;
372 wrapped_args.objc = objc;
373 wrapped_args.objv = objv;
374 wrapped_args.val = TCL_OK;
375
376 if (!catch_errors (wrapped_call, &wrapped_args, "", RETURN_MASK_ALL))
377 {
378
379 wrapped_args.val = TCL_ERROR; /* Flag an error for TCL */
380
381 /* Make sure the timer interrupts are turned off. */
382
383 gdbtk_stop_timer ();
384
385 gdb_flush (gdb_stderr); /* Flush error output */
386 gdb_flush (gdb_stdout); /* Sometimes error output comes here as well */
387
388 /* If we errored out here, and the results were going to the
389 console, then gdbtk_fputs will have gathered the result into the
390 result_ptr. We also need to echo them out to the console here */
391
392 gdb_flush (gdb_stderr); /* Flush error output */
393 gdb_flush (gdb_stdout); /* Sometimes error output comes here as well */
394
395 /* In case of an error, we may need to force the GUI into idle
396 mode because gdbtk_call_command may have bombed out while in
397 the command routine. */
398
399 running_now = 0;
400 Tcl_Eval (interp, "gdbtk_tcl_idle");
401
402 }
403
404 /* do not suppress any errors -- a remote target could have errored */
405 load_in_progress = 0;
406
407 /*
408 * Now copy the result over to the true Tcl result. If GDBTK_TO_RESULT flag
409 * bit is set , this just copies a null object over to the Tcl result, which is
410 * fine because we should reset the result in this case anyway.
411 */
412 if (result_ptr->flags & GDBTK_IN_TCL_RESULT)
413 {
414 Tcl_DecrRefCount(result_ptr->obj_ptr);
415 }
416 else
417 {
418 Tcl_SetObjResult (interp, result_ptr->obj_ptr);
419 }
420
421 result_ptr = old_result_ptr;
422
423#ifdef _WIN32
424 close_bfds ();
425#endif
426
427 return wrapped_args.val;
428}
429
430/*
431 * This is the wrapper that is passed to catch_errors.
432 */
433
434static int
435wrapped_call (opaque_args)
436 char *opaque_args;
437{
438 struct wrapped_call_args *args = (struct wrapped_call_args *) opaque_args;
439 args->val = (*args->func) (args->func, args->interp, args->objc, args->objv);
440 return 1;
441}
442
443/* This is a convenience function to sprintf something(s) into a
444 * new element in a Tcl list object.
445 */
446
447static void
448#ifdef ANSI_PROTOTYPES
449sprintf_append_element_to_obj (Tcl_Obj *objp, char *format, ...)
450#else
451sprintf_append_element_to_obj (va_alist)
452 va_dcl
453#endif
454{
455 va_list args;
456 char buf[1024];
457
458#ifdef ANSI_PROTOTYPES
459 va_start (args, format);
460#else
461 Tcl_Obj *objp;
462 char *format;
463
464 va_start (args);
465 dsp = va_arg (args, Tcl_Obj *);
466 format = va_arg (args, char *);
467#endif
468
469 vsprintf (buf, format, args);
470
471 Tcl_ListObjAppendElement (NULL, objp, Tcl_NewStringObj (buf, -1));
472}
473\f
474/*
475 * This section contains the commands that control execution.
476 */
477
478/* This implements the tcl command gdb_clear_file.
479 *
480 * Prepare to accept a new executable file. This is called when we
481 * want to clear away everything we know about the old file, without
482 * asking the user. The Tcl code will have already asked the user if
483 * necessary. After this is called, we should be able to run the
484 * `file' command without getting any questions.
485 *
486 * Arguments:
487 * None
488 * Tcl Result:
489 * None
490 */
491
492static int
493gdb_clear_file (clientData, interp, objc, objv)
494 ClientData clientData;
495 Tcl_Interp *interp;
496 int objc;
497 Tcl_Obj *CONST objv[];
498{
499 if (objc != 1)
500 Tcl_SetStringObj (result_ptr->obj_ptr,
501 "Wrong number of args, none are allowed.", -1);
502
503 if (inferior_pid != 0 && target_has_execution)
504 {
505 if (attach_flag)
4af2d83a 506 target_detach (NULL, 0);
ca4e7e14 507 else
4af2d83a 508 target_kill ();
ca4e7e14
JI		 509 }
510
511 if (target_has_execution)
512 pop_target ();
513
514 symbol_file_command (NULL, 0);
515
516 /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
517 clear it here. FIXME: This seems like an abstraction violation
518 somewhere. */
519 stop_pc = 0;
520
521 return TCL_OK;
522}
523
524/* This implements the tcl command gdb_confirm_quit
525 * Ask the user to confirm an exit request.
526 *
527 * Arguments:
528 * None
529 * Tcl Result:
530 * A boolean, 1 if the user answered yes, 0 if no.
531 */
532
533static int
534gdb_confirm_quit (clientData, interp, objc, objv)
535 ClientData clientData;
536 Tcl_Interp *interp;
537 int objc;
538 Tcl_Obj *CONST objv[];
539{
540 int ret;
541
542 if (objc != 1)
543 {
544 Tcl_SetStringObj (result_ptr->obj_ptr, "Wrong number of args, should be none.", -1);
545 return TCL_ERROR;
546 }
547
548 ret = quit_confirm ();
549 Tcl_SetBooleanObj (result_ptr->obj_ptr, ret);
550 return TCL_OK;
551}
552
553/* This implements the tcl command gdb_force_quit
554 * Quit without asking for confirmation.
555 *
556 * Arguments:
557 * None
558 * Tcl Result:
559 * None
560 */
561
562static int
563gdb_force_quit (clientData, interp, objc, objv)
564 ClientData clientData;
565 Tcl_Interp *interp;
566 int objc;
567 Tcl_Obj *CONST objv[];
568{
569 if (objc != 1)
570 {
571 Tcl_SetStringObj (result_ptr->obj_ptr, "Wrong number of args, should be none.", -1);
572 return TCL_ERROR;
573 }
574
575 quit_force ((char *) NULL, 1);
576 return TCL_OK;
577}
578
579/* This implements the tcl command gdb_stop
580 * It stops the target in a continuable fashion.
581 *
582 * Arguments:
583 * None
584 * Tcl Result:
585 * None
586 */
587
588static int
589gdb_stop (clientData, interp, objc, objv)
590 ClientData clientData;
591 Tcl_Interp *interp;
592 int objc;
593 Tcl_Obj *CONST objv[];
594{
2c04e0d9 595 if (target_stop != target_ignore)
ca4e7e14 596 target_stop ();
ca4e7e14
JI		 597 else
598 quit_flag = 1; /* hope something sees this */
599
600 return TCL_OK;
601}
602
603\f
604/*
605 * This section contains Tcl commands that are wrappers for invoking
606 * the GDB command interpreter.
607 */
608
609
610/* This implements the tcl command `gdb_eval'.
611 * It uses the gdb evaluator to return the value of
612 * an expression in the current language
613 *
614 * Tcl Arguments:
615 * expression - the expression to evaluate.
616 * Tcl Result:
617 * The result of the evaluation.
618 */
619
620static int
621gdb_eval (clientData, interp, objc, objv)
622 ClientData clientData;
623 Tcl_Interp *interp;
624 int objc;
625 Tcl_Obj *CONST objv[];
626{
627 struct expression *expr;
6f5af15b 628 struct cleanup *old_chain=NULL;
ca4e7e14
JI		 629 value_ptr val;
630
631 if (objc != 2)
632 {
633 Tcl_SetStringObj (result_ptr->obj_ptr,
634 "wrong # args, should be \"gdb_eval expression\"", -1);
635 return TCL_ERROR;
636 }
637
638 expr = parse_expression (Tcl_GetStringFromObj (objv[1], NULL));
639
ad3b8c4a 640 old_chain = make_cleanup ((make_cleanup_func) free_current_contents, &expr);
ca4e7e14
JI		 641
642 val = evaluate_expression (expr);
643
644 /*
645 * Print the result of the expression evaluation. This will go to
646 * eventually go to gdbtk_fputs, and from there be collected into
647 * the Tcl result.
648 */
649
650 val_print (VALUE_TYPE (val), VALUE_CONTENTS (val), VALUE_ADDRESS (val),
651 gdb_stdout, 0, 0, 0, 0);
652
653 do_cleanups (old_chain);
654
655 return TCL_OK;
656}
657
658/* This implements the tcl command "gdb_cmd".
659 *
660 * It sends its argument to the GDB command scanner for execution.
661 * This command will never cause the update, idle and busy hooks to be called
662 * within the GUI.
663 *
664 * Tcl Arguments:
665 * command - The GDB command to execute
666 * Tcl Result:
667 * The output from the gdb command (except for the "load" & "while"
668 * which dump their output to the console.
669 */
670
671static int
672gdb_cmd (clientData, interp, objc, objv)
673 ClientData clientData;
674 Tcl_Interp *interp;
675 int objc;
676 Tcl_Obj *CONST objv[];
677{
2aae6397
JI		 678 int from_tty = 0;
679
ca4e7e14
JI		 680 if (objc < 2)
681 {
682 Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
683 return TCL_ERROR;
684 }
685
2aae6397
JI		 686 if (objc == 3)
687 {
688 if (Tcl_GetBooleanFromObj (NULL, objv[2], &from_tty) != TCL_OK) {
689 Tcl_SetStringObj (result_ptr->obj_ptr, "from_tty must be a boolean.",
690 -1);
691 return TCL_ERROR;
692 }
693 }
694
ca4e7e14
JI		 695 if (running_now || load_in_progress)
696 return TCL_OK;
697
698 No_Update = 1;
699
700 /* for the load instruction (and possibly others later) we
701 set turn off the GDBTK_TO_RESULT flag bit so gdbtk_fputs()
702 will not buffer all the data until the command is finished. */
703
b2a9dbf7 704 if ((strncmp ("load ", Tcl_GetStringFromObj (objv[1], NULL), 5) == 0))
ca4e7e14
JI		 705 {
706 result_ptr->flags &= ~GDBTK_TO_RESULT;
707 load_in_progress = 1;
ca4e7e14
JI		 708 }
709
2aae6397 710 execute_command (Tcl_GetStringFromObj (objv[1], NULL), from_tty);
ca4e7e14
JI		 711
712 if (load_in_progress)
713 {
ca4e7e14
JI		 714 load_in_progress = 0;
715 result_ptr->flags |= GDBTK_TO_RESULT;
716 }
717
718 bpstat_do_actions (&stop_bpstat);
719
720 return TCL_OK;
721}
722
723/*
724 * This implements the tcl command "gdb_immediate"
725 *
726 * It does exactly the same thing as gdb_cmd, except NONE of its outut
727 * is buffered. This will also ALWAYS cause the busy, update, and idle hooks to
728 * be called, contrasted with gdb_cmd, which NEVER calls them.
729 * It turns off the GDBTK_TO_RESULT flag, which diverts the result
730 * to the console window.
731 *
732 * Tcl Arguments:
733 * command - The GDB command to execute
734 * Tcl Result:
735 * None.
736 */
737
738static int
739gdb_immediate_command (clientData, interp, objc, objv)
740 ClientData clientData;
741 Tcl_Interp *interp;
742 int objc;
743 Tcl_Obj *CONST objv[];
744{
745
746 if (objc != 2)
747 {
748 Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
749 return TCL_ERROR;
750 }
751
752 if (running_now || load_in_progress)
753 return TCL_OK;
754
755 No_Update = 0;
756
757 result_ptr->flags &= ~GDBTK_TO_RESULT;
758
759 execute_command (Tcl_GetStringFromObj (objv[1], NULL), 1);
760
761 bpstat_do_actions (&stop_bpstat);
762
763 result_ptr->flags |= GDBTK_TO_RESULT;
764
765 return TCL_OK;
766}
767
768/* This implements the tcl command "gdb_prompt"
769 *
770 * It returns the gdb interpreter's prompt.
771 *
772 * Tcl Arguments:
773 * None.
774 * Tcl Result:
775 * The prompt.
776 */
777
778static int
779gdb_prompt_command (clientData, interp, objc, objv)
780 ClientData clientData;
781 Tcl_Interp *interp;
782 int objc;
783 Tcl_Obj *CONST objv[];
784{
785 Tcl_SetStringObj (result_ptr->obj_ptr, get_prompt (), -1);
786 return TCL_OK;
787}
788
789\f
790/*
791 * This section contains general informational commands.
792 */
793
794/* This implements the tcl command "gdb_target_has_execution"
795 *
796 * Tells whether the target is executing.
797 *
798 * Tcl Arguments:
799 * None
800 * Tcl Result:
801 * A boolean indicating whether the target is executing.
802 */
803
804static int
805gdb_target_has_execution_command (clientData, interp, objc, objv)
806 ClientData clientData;
807 Tcl_Interp *interp;
808 int objc;
809 Tcl_Obj *CONST objv[];
810{
811 int result = 0;
812
813 if (target_has_execution && inferior_pid != 0)
814 result = 1;
815
816 Tcl_SetBooleanObj (result_ptr->obj_ptr, result);
817 return TCL_OK;
818}
819
820/* This implements the tcl command "gdb_load_info"
821 *
822 * It returns information about the file about to be downloaded.
823 *
824 * Tcl Arguments:
825 * filename: The file to open & get the info on.
826 * Tcl Result:
827 * A list consisting of the name and size of each section.
828 */
829
830static int
831gdb_load_info (clientData, interp, objc, objv)
832 ClientData clientData;
833 Tcl_Interp *interp;
834 int objc;
835 Tcl_Obj *CONST objv[];
836{
837 bfd *loadfile_bfd;
838 struct cleanup *old_cleanups;
839 asection *s;
840 Tcl_Obj *ob[2];
ca4e7e14
JI		 841
842 char *filename = Tcl_GetStringFromObj (objv[1], NULL);
843
844 loadfile_bfd = bfd_openr (filename, gnutarget);
845 if (loadfile_bfd == NULL)
846 {
847 Tcl_SetStringObj (result_ptr->obj_ptr, "Open failed", -1);
848 return TCL_ERROR;
849 }
ad3b8c4a 850 old_cleanups = make_cleanup ((make_cleanup_func) bfd_close, loadfile_bfd);
ca4e7e14
JI		 851
852 if (!bfd_check_format (loadfile_bfd, bfd_object))
853 {
854 Tcl_SetStringObj (result_ptr->obj_ptr, "Bad Object File", -1);
855 return TCL_ERROR;
856 }
857
858 Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
859
860 for (s = loadfile_bfd->sections; s; s = s->next)
861 {
862 if (s->flags & SEC_LOAD)
4af2d83a
KS		 863 {
864 bfd_size_type size = bfd_get_section_size_before_reloc (s);
865 if (size > 0)
866 {
867 ob[0] = Tcl_NewStringObj ((char *) bfd_get_section_name (loadfile_bfd, s), -1);
868 ob[1] = Tcl_NewLongObj ((long) size);
869 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewListObj (2, ob));
870 }
871 }
ca4e7e14
JI		 872 }
873
874 do_cleanups (old_cleanups);
875 return TCL_OK;
876}
877
878
879/* gdb_get_locals -
880 * This and gdb_get_locals just call gdb_get_vars_command with the right
881 * value of clientData. We can't use the client data in the definition
882 * of the command, because the call wrapper uses this instead...
883 */
884
885static int
886gdb_get_locals_command (clientData, interp, objc, objv)
887 ClientData clientData;
888 Tcl_Interp *interp;
889 int objc;
890 Tcl_Obj *CONST objv[];
891{
892
893 return gdb_get_vars_command((ClientData) 0, interp, objc, objv);
894
895}
896
897static int
898gdb_get_args_command (clientData, interp, objc, objv)
899 ClientData clientData;
900 Tcl_Interp *interp;
901 int objc;
902 Tcl_Obj *CONST objv[];
903{
904
905 return gdb_get_vars_command((ClientData) 1, interp, objc, objv);
906
907}
908
909/* This implements the tcl commands "gdb_get_locals" and "gdb_get_args"
910 *
911 * This function sets the Tcl interpreter's result to a list of variable names
912 * depending on clientData. If clientData is one, the result is a list of
913 * arguments; zero returns a list of locals -- all relative to the block
914 * specified as an argument to the command. Valid commands include
915 * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
916 * and "main").
917 *
918 * Tcl Arguments:
919 * block - the address within which to specify the locals or args.
920 * Tcl Result:
921 * A list of the locals or args
922 */
923
924static int
925gdb_get_vars_command (clientData, interp, objc, objv)
926 ClientData clientData;
927 Tcl_Interp *interp;
928 int objc;
929 Tcl_Obj *CONST objv[];
930{
931 struct symtabs_and_lines sals;
932 struct symbol *sym;
933 struct block *block;
934 char **canonical, *args;
935 int i, nsyms, arguments;
936
937 if (objc != 2)
938 {
939 Tcl_AppendStringsToObj (result_ptr->obj_ptr,
940 "wrong # of args: should be \"",
941 Tcl_GetStringFromObj (objv[0], NULL),
942 " function:line|function|line|*addr\"", NULL);
943 return TCL_ERROR;
944 }
945
946 arguments = (int) clientData;
947 args = Tcl_GetStringFromObj (objv[1], NULL);
948 sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
949 if (sals.nelts == 0)
950 {
951 Tcl_SetStringObj (result_ptr->obj_ptr,
952 "error decoding line", -1);
953 return TCL_ERROR;
954 }
955
956 /* Initialize the result pointer to an empty list. */
957
958 Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
959
960 /* Resolve all line numbers to PC's */
961 for (i = 0; i < sals.nelts; i++)
962 resolve_sal_pc (&sals.sals[i]);
963
964 block = block_for_pc (sals.sals[0].pc);
965 while (block != 0)
966 {
967 nsyms = BLOCK_NSYMS (block);
968 for (i = 0; i < nsyms; i++)
969 {
970 sym = BLOCK_SYM (block, i);
971 switch (SYMBOL_CLASS (sym)) {
972 default:
973 case LOC_UNDEF: /* catches errors */
974 case LOC_CONST: /* constant */
ca4e7e14
JI		 975 case LOC_TYPEDEF: /* local typedef */
976 case LOC_LABEL: /* local label */
977 case LOC_BLOCK: /* local function */
978 case LOC_CONST_BYTES: /* loc. byte seq. */
979 case LOC_UNRESOLVED: /* unresolved static */
980 case LOC_OPTIMIZED_OUT: /* optimized out */
981 break;
982 case LOC_ARG: /* argument */
983 case LOC_REF_ARG: /* reference arg */
984 case LOC_REGPARM: /* register arg */
985 case LOC_REGPARM_ADDR: /* indirect register arg */
986 case LOC_LOCAL_ARG: /* stack arg */
987 case LOC_BASEREG_ARG: /* basereg arg */
988 if (arguments)
989 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
990 Tcl_NewStringObj (SYMBOL_NAME (sym), -1));
991 break;
992 case LOC_LOCAL: /* stack local */
993 case LOC_BASEREG: /* basereg local */
4af2d83a
KS		 994 case LOC_STATIC: /* static */
995 case LOC_REGISTER: /* register */
ca4e7e14
JI		 996 if (!arguments)
997 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
998 Tcl_NewStringObj (SYMBOL_NAME (sym), -1));
999 break;
1000 }
1001 }
1002 if (BLOCK_FUNCTION (block))
1003 break;
1004 else
1005 block = BLOCK_SUPERBLOCK (block);
1006 }
1007
1008 return TCL_OK;
1009}
1010
1011/* This implements the tcl command "gdb_get_line"
1012 *
1013 * It returns the linenumber for a given linespec. It will take any spec
1014 * that can be passed to decode_line_1
1015 *
1016 * Tcl Arguments:
1017 * linespec - the line specification
1018 * Tcl Result:
1019 * The line number for that spec.
1020 */
1021static int
1022gdb_get_line_command (clientData, interp, objc, objv)
1023 ClientData clientData;
1024 Tcl_Interp *interp;
1025 int objc;
1026 Tcl_Obj *CONST objv[];
1027{
ca4e7e14
JI		 1028 struct symtabs_and_lines sals;
1029 char *args, **canonical;
1030
1031 if (objc != 2)
1032 {
1033 Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
1034 Tcl_GetStringFromObj (objv[0], NULL),
1035 " linespec\"", NULL);
1036 return TCL_ERROR;
1037 }
1038
1039 args = Tcl_GetStringFromObj (objv[1], NULL);
1040 sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
1041 if (sals.nelts == 1)
1042 {
1043 Tcl_SetIntObj (result_ptr->obj_ptr, sals.sals[0].line);
1044 return TCL_OK;
1045 }
1046
1047 Tcl_SetStringObj (result_ptr->obj_ptr, "N/A", -1);
1048 return TCL_OK;
1049
1050}
1051
1052/* This implements the tcl command "gdb_get_file"
1053 *
1054 * It returns the file containing a given line spec.
1055 *
1056 * Tcl Arguments:
1057 * linespec - The linespec to look up
1058 * Tcl Result:
1059 * The file containing it.
1060 */
1061
1062static int
1063gdb_get_file_command (clientData, interp, objc, objv)
1064 ClientData clientData;
1065 Tcl_Interp *interp;
1066 int objc;
1067 Tcl_Obj *CONST objv[];
1068{
ca4e7e14
JI		 1069 struct symtabs_and_lines sals;
1070 char *args, **canonical;
1071
1072 if (objc != 2)
1073 {
1074 Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
1075 Tcl_GetStringFromObj (objv[0], NULL),
1076 " linespec\"", NULL);
1077 return TCL_ERROR;
1078 }
1079
1080 args = Tcl_GetStringFromObj (objv[1], NULL);
1081 sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
1082 if (sals.nelts == 1)
1083 {
1084 Tcl_SetStringObj (result_ptr->obj_ptr, sals.sals[0].symtab->filename, -1);
1085 return TCL_OK;
1086 }
1087
1088 Tcl_SetStringObj (result_ptr->obj_ptr, "N/A", -1);
1089 return TCL_OK;
1090}
1091
1092/* This implements the tcl command "gdb_get_function"
1093 *
1094 * It finds the function containing the given line spec.
1095 *
1096 * Tcl Arguments:
1097 * linespec - The line specification
1098 * Tcl Result:
1099 * The function that contains it, or "N/A" if it is not in a function.
1100 */
1101static int
1102gdb_get_function_command (clientData, interp, objc, objv)
1103 ClientData clientData;
1104 Tcl_Interp *interp;
1105 int objc;
1106 Tcl_Obj *CONST objv[];
1107{
1108 char *function;
1109 struct symtabs_and_lines sals;
1110 char *args, **canonical;
1111
1112 if (objc != 2)
1113 {
1114 Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
1115 Tcl_GetStringFromObj (objv[0], NULL),
1116 " linespec\"", NULL);
1117 return TCL_ERROR;
1118 }
1119
1120 args = Tcl_GetStringFromObj (objv[1], NULL);
1121 sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
1122 if (sals.nelts == 1)
1123 {
1124 resolve_sal_pc (&sals.sals[0]);
1125 find_pc_partial_function (sals.sals[0].pc, &function, NULL, NULL);
1126 if (function != NULL)
1127 {
1128 Tcl_SetStringObj (result_ptr->obj_ptr, function, -1);
1129 return TCL_OK;
1130 }
1131 }
1132
1133 Tcl_SetStringObj (result_ptr->obj_ptr, "N/A", -1);
1134 return TCL_OK;
1135}
1136
1137/* This implements the tcl command "gdb_find_file"
1138 *
1139 * It searches the symbol tables to get the full pathname to a file.
1140 *
1141 * Tcl Arguments:
1142 * filename: the file name to search for.
1143 * Tcl Result:
1144 * The full path to the file, or an empty string if the file is not
1145 * found.
1146 */
1147
1148static int
1149gdb_find_file_command (clientData, interp, objc, objv)
1150 ClientData clientData;
1151 Tcl_Interp *interp;
1152 int objc;
1153 Tcl_Obj *CONST objv[];
1154{
1155 char *filename = NULL;
1156 struct symtab *st;
1157
1158 if (objc != 2)
1159 {
1160 Tcl_WrongNumArgs(interp, 1, objv, "filename");
1161 return TCL_ERROR;
1162 }
1163
1164 st = full_lookup_symtab (Tcl_GetStringFromObj (objv[1], NULL));
1165 if (st)
1166 filename = st->fullname;
1167
1168 if (filename == NULL)
1169 Tcl_SetStringObj (result_ptr->obj_ptr, "", 0);
1170 else
1171 Tcl_SetStringObj (result_ptr->obj_ptr, filename, -1);
1172
1173 return TCL_OK;
1174}
1175
1176/* This implements the tcl command "gdb_listfiles"
1177 *
1178 * This lists all the files in the current executible.
1179 *
9c56157f
MH		 1180 * Note that this currently pulls in all sorts of filenames
1181 * that aren't really part of the executable. It would be
1182 * best if we could check each file to see if it actually
1183 * contains executable lines of code, but we can't do that
1184 * with psymtabs.
1185 *
ca4e7e14
JI		 1186 * Arguments:
1187 * ?pathname? - If provided, only files which match pathname
9c56157f
MH		 1188 * (up to strlen(pathname)) are included. THIS DOES NOT
1189 * CURRENTLY WORK BECAUSE PARTIAL_SYMTABS DON'T SUPPLY
1190 * THE FULL PATHNAME!!!
1191 *
ca4e7e14
JI		 1192 * Tcl Result:
1193 * A list of all matching files.
1194 */
ca4e7e14
JI		 1195static int
1196gdb_listfiles (clientData, interp, objc, objv)
1197 ClientData clientData;
1198 Tcl_Interp *interp;
1199 int objc;
1200 Tcl_Obj *CONST objv[];
1201{
1202 struct objfile *objfile;
1203 struct partial_symtab *psymtab;
1204 struct symtab *symtab;
6f5af15b 1205 char *lastfile, *pathname=NULL, **files;
ca4e7e14
JI		 1206 int files_size;
1207 int i, numfiles = 0, len = 0;
ca4e7e14
JI		 1208
1209 files_size = 1000;
1210 files = (char **) xmalloc (sizeof (char *) * files_size);
6f5af15b 1211
ca4e7e14
JI		 1212 if (objc > 2)
1213 {
1214 Tcl_WrongNumArgs (interp, 1, objv, "Usage: gdb_listfiles ?pathname?");
1215 return TCL_ERROR;
1216 }
1217 else if (objc == 2)
1218 pathname = Tcl_GetStringFromObj (objv[1], &len);
1219
1220 ALL_PSYMTABS (objfile, psymtab)
1221 {
1222 if (numfiles == files_size)
1223 {
4af2d83a
KS		 1224 files_size = files_size * 2;
1225 files = (char **) xrealloc (files, sizeof (char *) * files_size);
ca4e7e14 1226 }
9c56157f 1227 if (psymtab->filename)
4af2d83a
KS		 1228 {
1229 if (!len || !strncmp(pathname, psymtab->filename,len)
1230 || !strcmp(psymtab->filename, basename(psymtab->filename)))
1231 {
1232 files[numfiles++] = basename(psymtab->filename);
1233 }
1234 }
ca4e7e14
JI		 1235 }
1236
1237 ALL_SYMTABS (objfile, symtab)
1238 {
1239 if (numfiles == files_size)
1240 {
4af2d83a
KS		 1241 files_size = files_size * 2;
1242 files = (char **) xrealloc (files, sizeof (char *) * files_size);
ca4e7e14 1243 }
9c56157f 1244 if (symtab->filename && symtab->linetable && symtab->linetable->nitems)
4af2d83a
KS		 1245 {
1246 if (!len || !strncmp(pathname, symtab->filename,len)
1247 || !strcmp(symtab->filename, basename(symtab->filename)))
1248 {
1249 files[numfiles++] = basename(symtab->filename);
1250 }
1251 }
ca4e7e14
JI		 1252 }
1253
1254 qsort (files, numfiles, sizeof(char *), comp_files);
1255
1256 lastfile = "";
1257
1258 /* Discard the old result pointer, in case it has accumulated anything
1259 and set it to a new list object */
1260
1261 Tcl_SetListObj(result_ptr->obj_ptr, 0, NULL);
1262
1263 for (i = 0; i < numfiles; i++)
1264 {
1265 if (strcmp(files[i],lastfile))
4af2d83a 1266 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewStringObj(files[i], -1));
ca4e7e14
JI		 1267 lastfile = files[i];
1268 }
1269
1270 free (files);
1271 return TCL_OK;
1272}
1273
1274static int
1275comp_files (file1, file2)
1276 const void *file1, *file2;
1277{
1278 return strcmp(* (char **) file1, * (char **) file2);
1279}
1280
1281
1282/* This implements the tcl command "gdb_search"
1283 *
1284 *
1285 * Tcl Arguments:
1286 * option - One of "functions", "variables" or "types"
1287 * regexp - The regular expression to look for.
1288 * Then, optionally:
1289 * -files fileList
1290 * -static 1/0
1291 * Tcl Result:
1292 *
1293 */
1294
1295static int
1296gdb_search (clientData, interp, objc, objv)
1297 ClientData clientData;
1298 Tcl_Interp *interp;
1299 int objc;
1300 Tcl_Obj *CONST objv[];
1301{
850e1491 1302 struct symbol_search *ss = NULL;
ca4e7e14 1303 struct symbol_search *p;
6f5af15b
MH		 1304 struct cleanup *old_chain = NULL;
1305 Tcl_Obj *CONST *switch_objv;
ca4e7e14 1306 int index, switch_objc, i;
6f5af15b
MH		 1307 namespace_enum space = 0;
1308 char *regexp;
ca4e7e14
JI		 1309 int static_only, nfiles;
1310 Tcl_Obj **file_list;
1311 char **files;
1312 static char *search_options[] = { "functions", "variables", "types", (char *) NULL };
850e1491 1313 static char *switches[] = { "-files", "-static", (char *) NULL };
ca4e7e14
JI		 1314 enum search_opts { SEARCH_FUNCTIONS, SEARCH_VARIABLES, SEARCH_TYPES };
1315 enum switches_opts { SWITCH_FILES, SWITCH_STATIC_ONLY };
1316
1317 if (objc < 3)
1318 {
1319 Tcl_WrongNumArgs (interp, 1, objv, "option regexp ?arg ...?");
850e1491 1320 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
ca4e7e14
JI		 1321 return TCL_ERROR;
1322 }
1323
1324 if (Tcl_GetIndexFromObj (interp, objv[1], search_options, "option", 0,
1325 &index) != TCL_OK)
850e1491
KS		 1326 {
1327 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1328 return TCL_ERROR;
1329 }
ca4e7e14
JI		 1330
1331 /* Unfortunately, we cannot teach search_symbols to search on
1332 multiple regexps, so we have to do a two-tier search for
1333 any searches which choose to narrow the playing field. */
1334 switch ((enum search_opts) index)
1335 {
1336 case SEARCH_FUNCTIONS:
1337 space = FUNCTIONS_NAMESPACE; break;
1338 case SEARCH_VARIABLES:
1339 space = VARIABLES_NAMESPACE; break;
1340 case SEARCH_TYPES:
1341 space = TYPES_NAMESPACE; break;
1342 }
1343
1344 regexp = Tcl_GetStringFromObj (objv[2], NULL);
1345 /* Process any switches that refine the search */
1346 switch_objc = objc - 3;
1347 switch_objv = objv + 3;
1348
1349 static_only = 0;
1350 nfiles = 0;
1351 files = (char **) NULL;
1352 while (switch_objc > 0)
1353 {
1354 if (Tcl_GetIndexFromObj (interp, switch_objv[0], switches,
1355 "option", 0, &index) != TCL_OK)
850e1491
KS		 1356 {
1357 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1358 return TCL_ERROR;
1359 }
ca4e7e14
JI		 1360
1361 switch ((enum switches_opts) index)
1362 {
1363 case SWITCH_FILES:
850e1491
KS		 1364 {
1365 int result;
1366 if (switch_objc < 2)
1367 {
1368 Tcl_WrongNumArgs (interp, 2, objv, "[-files fileList -static 1|0]");
1369 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1370 return TCL_ERROR;
1371 }
1372 result = Tcl_ListObjGetElements (interp, switch_objv[1], &nfiles, &file_list);
1373 if (result != TCL_OK)
1374 return result;
1375
1376 files = (char **) xmalloc (nfiles * sizeof (char *));
1377 for (i = 0; i < nfiles; i++)
ca4e7e14 1378 files[i] = Tcl_GetStringFromObj (file_list[i], NULL);
850e1491
KS		 1379 switch_objc--;
1380 switch_objv++;
1381 }
ca4e7e14
JI		 1382 break;
1383 case SWITCH_STATIC_ONLY:
1384 if (switch_objc < 2)
1385 {
1386 Tcl_WrongNumArgs (interp, 2, objv, "[-files fileList] [-static 1|0]");
850e1491 1387 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
ca4e7e14
JI		 1388 return TCL_ERROR;
1389 }
1390 if ( Tcl_GetBooleanFromObj (interp, switch_objv[1], &static_only) !=
850e1491
KS		 1391 TCL_OK) {
1392 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1393 return TCL_ERROR;
1394 }
ca4e7e14
JI		 1395 switch_objc--;
1396 switch_objv++;
1397 }
ca4e7e14
JI		 1398 switch_objc--;
1399 switch_objv++;
1400 }
1401
1402 search_symbols (regexp, space, nfiles, files, &ss);
850e1491 1403 if (ss != NULL)
ad3b8c4a 1404 old_chain = make_cleanup ((make_cleanup_func) free_search_symbols, ss);
850e1491
KS		 1405
1406 Tcl_SetListObj(result_ptr->obj_ptr, 0, NULL);
1407
ca4e7e14
JI		 1408 for (p = ss; p != NULL; p = p->next)
1409 {
1410 Tcl_Obj *elem;
1411
1412 if (static_only && p->block != STATIC_BLOCK)
1413 continue;
1414
c888792a
KS		 1415 /* Strip off some C++ special symbols, like RTTI and global
1416 constructors/destructors. */
1417 if ((p->symbol != NULL && !STREQN (SYMBOL_NAME (p->symbol), "__tf", 4)
1418 && !STREQN (SYMBOL_NAME (p->symbol), "_GLOBAL_", 8))
1419 || p->msymbol != NULL)
1420 {
1421 elem = Tcl_NewListObj (0, NULL);
ca4e7e14 1422
c888792a
KS		 1423 if (p->msymbol == NULL)
1424 Tcl_ListObjAppendElement (interp, elem,
1425 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p->symbol), -1));
1426 else
1427 Tcl_ListObjAppendElement (interp, elem,
1428 Tcl_NewStringObj (SYMBOL_SOURCE_NAME (p->msymbol), -1));
ca4e7e14 1429
c888792a
KS		 1430 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, elem);
1431 }
ca4e7e14
JI		 1432 }
1433
850e1491
KS		 1434 if (ss != NULL)
1435 do_cleanups (old_chain);
1436
ca4e7e14
JI		 1437 return TCL_OK;
1438}
1439
1440/* This implements the tcl command gdb_listfuncs
1441 *
1442 * It lists all the functions defined in a given file
1443 *
1444 * Arguments:
1445 * file - the file to look in
1446 * Tcl Result:
1447 * A list of two element lists, the first element is
1448 * the symbol name, and the second is a boolean indicating
1449 * whether the symbol is demangled (1 for yes).
1450 */
1451
1452static int
1453gdb_listfuncs (clientData, interp, objc, objv)
1454 ClientData clientData;
1455 Tcl_Interp *interp;
1456 int objc;
1457 Tcl_Obj *CONST objv[];
1458{
1459 struct symtab *symtab;
1460 struct blockvector *bv;
1461 struct block *b;
1462 struct symbol *sym;
ca4e7e14
JI		 1463 int i,j;
1464 Tcl_Obj *funcVals[2];
1465
1466 if (objc != 2)
1467 {
1468 Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
1469 }
1470
1471 symtab = full_lookup_symtab (Tcl_GetStringFromObj (objv[1], NULL));
1472 if (!symtab)
1473 {
1474 Tcl_SetStringObj (result_ptr->obj_ptr, "No such file", -1);
1475 return TCL_ERROR;
1476 }
1477
1478 if (mangled == NULL)
1479 {
1480 mangled = Tcl_NewBooleanObj(1);
1481 not_mangled = Tcl_NewBooleanObj(0);
1482 Tcl_IncrRefCount(mangled);
1483 Tcl_IncrRefCount(not_mangled);
1484 }
1485
1486 Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
1487
1488 bv = BLOCKVECTOR (symtab);
1489 for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
1490 {
1491 b = BLOCKVECTOR_BLOCK (bv, i);
1492 /* Skip the sort if this block is always sorted. */
1493 if (!BLOCK_SHOULD_SORT (b))
4af2d83a 1494 sort_block_syms (b);
ca4e7e14 1495 for (j = 0; j < BLOCK_NSYMS (b); j++)
4af2d83a
KS		 1496 {
1497 sym = BLOCK_SYM (b, j);
1498 if (SYMBOL_CLASS (sym) == LOC_BLOCK)
1499 {
ca4e7e14 1500
4af2d83a
KS		 1501 char *name = cplus_demangle (SYMBOL_NAME(sym), 0);
1502 if (name)
1503 {
1504 /* strip out "global constructors" and "global destructors" */
1505 /* because we aren't interested in them. */
1506 if (strncmp (name, "global ", 7))
1507 {
1508 funcVals[0] = Tcl_NewStringObj(name, -1);
1509 funcVals[1] = mangled;
1510 }
1511 else
1512 continue;
1513
1514 }
1515 else
1516 {
1517 funcVals[0] = Tcl_NewStringObj(SYMBOL_NAME(sym), -1);
1518 funcVals[1] = not_mangled;
1519 }
1520 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
1521 Tcl_NewListObj (2, funcVals));
1522 }
1523 }
ca4e7e14
JI		 1524 }
1525 return TCL_OK;
1526}
1527
1528\f
1529/*
1530 * This section contains all the commands that act on the registers:
1531 */
1532
1533/* This is a sort of mapcar function for operations on registers */
1534
1535static int
1536map_arg_registers (objc, objv, func, argp)
1537 int objc;
1538 Tcl_Obj *CONST objv[];
1539 void (*func) PARAMS ((int regnum, void *argp));
1540 void *argp;
1541{
1542 int regnum;
1543
1544 /* Note that the test for a valid register must include checking the
d70a61e7
AC		 1545 REGISTER_NAME because NUM_REGS may be allocated for the union of
1546 the register sets within a family of related processors. In this
1547 case, some entries of REGISTER_NAME will change depending upon
1548 the particular processor being debugged. */
ca4e7e14
JI		 1549
1550 if (objc == 0) /* No args, just do all the regs */
1551 {
1552 for (regnum = 0;
4af2d83a 1553 regnum < NUM_REGS
d70a61e7
AC		 1554 && REGISTER_NAME (regnum) != NULL
1555 && *REGISTER_NAME (regnum) != '\000';
4af2d83a
KS		 1556 regnum++)
1557 func (regnum, argp);
ca4e7e14
JI		 1558
1559 return TCL_OK;
1560 }
1561
1562 /* Else, list of register #s, just do listed regs */
1563 for (; objc > 0; objc--, objv++)
1564 {
4af2d83a
KS		 1565 if (Tcl_GetIntFromObj (NULL, *objv, &regnum) != TCL_OK)
1566 {
1567 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1568 return TCL_ERROR;
1569 }
ca4e7e14
JI		 1570
1571 if (regnum >= 0
4af2d83a 1572 && regnum < NUM_REGS
d70a61e7
AC		 1573 && REGISTER_NAME (regnum) != NULL
1574 && *REGISTER_NAME (regnum) != '\000')
4af2d83a 1575 func (regnum, argp);
ca4e7e14 1576 else
4af2d83a
KS		 1577 {
1578 Tcl_SetStringObj (result_ptr->obj_ptr, "bad register number", -1);
1579 return TCL_ERROR;
1580 }
ca4e7e14
JI		 1581 }
1582
1583 return TCL_OK;
1584}
1585
1586/* This implements the TCL command `gdb_regnames', which returns a list of
1587 all of the register names. */
1588
1589static int
1590gdb_regnames (clientData, interp, objc, objv)
1591 ClientData clientData;
1592 Tcl_Interp *interp;
1593 int objc;
1594 Tcl_Obj *CONST objv[];
1595{
1596 objc--;
1597 objv++;
1598
1599 return map_arg_registers (objc, objv, get_register_name, NULL);
1600}
1601
1602static void
1603get_register_name (regnum, argp)
1604 int regnum;
1605 void *argp; /* Ignored */
1606{
1607 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
d70a61e7 1608 Tcl_NewStringObj (REGISTER_NAME (regnum), -1));
ca4e7e14
JI		 1609}
1610
1611/* This implements the tcl command gdb_fetch_registers
1612 * Pass it a list of register names, and it will
1613 * return their values as a list.
1614 *
1615 * Tcl Arguments:
1616 * format: The format string for printing the values
1617 * args: the registers to look for
1618 * Tcl Result:
1619 * A list of their values.
1620 */
1621
1622static int
1623gdb_fetch_registers (clientData, interp, objc, objv)
1624 ClientData clientData;
1625 Tcl_Interp *interp;
1626 int objc;
1627 Tcl_Obj *CONST objv[];
1628{
1629 int format, result;
1630
1631 if (objc < 2)
1632 {
1633 Tcl_SetStringObj (result_ptr->obj_ptr,
4af2d83a 1634 "wrong # args, should be gdb_fetch_registers format ?register1 register2 ...?", -1);
ca4e7e14
JI		 1635 }
1636 objc -= 2;
1637 objv++;
1638 format = *(Tcl_GetStringFromObj(objv[0], NULL));
1639 objv++;
1640
1641
1642 result_ptr->flags |= GDBTK_MAKES_LIST; /* Output the results as a list */
1643 result = map_arg_registers (objc, objv, get_register, (void *) format);
1644 result_ptr->flags &= ~GDBTK_MAKES_LIST;
1645
1646 return result;
1647}
1648
1649static void
1650get_register (regnum, fp)
1651 int regnum;
1652 void *fp;
1653{
1654 char raw_buffer[MAX_REGISTER_RAW_SIZE];
1655 char virtual_buffer[MAX_REGISTER_VIRTUAL_SIZE];
1656 int format = (int)fp;
1657
1658 if (format == 'N')
1659 format = 0;
1660
1661 if (read_relative_register_raw_bytes (regnum, raw_buffer))
1662 {
1663 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
1664 Tcl_NewStringObj ("Optimized out", -1));
1665 return;
1666 }
1667
1668 /* Convert raw data to virtual format if necessary. */
1669
1670 if (REGISTER_CONVERTIBLE (regnum))
1671 {
1672 REGISTER_CONVERT_TO_VIRTUAL (regnum, REGISTER_VIRTUAL_TYPE (regnum),
4af2d83a 1673 raw_buffer, virtual_buffer);
ca4e7e14
JI		 1674 }
1675 else
1676 memcpy (virtual_buffer, raw_buffer, REGISTER_VIRTUAL_SIZE (regnum));
1677
1678 if (format == 'r')
1679 {
1680 int j;
1681 printf_filtered ("0x");
1682 for (j = 0; j < REGISTER_RAW_SIZE (regnum); j++)
4af2d83a
KS		 1683 {
1684 register int idx = TARGET_BYTE_ORDER == BIG_ENDIAN ? j
1685 : REGISTER_RAW_SIZE (regnum) - 1 - j;
1686 printf_filtered ("%02x", (unsigned char)raw_buffer[idx]);
1687 }
ca4e7e14
JI		 1688 }
1689 else
1690 val_print (REGISTER_VIRTUAL_TYPE (regnum), virtual_buffer, 0,
4af2d83a 1691 gdb_stdout, format, 1, 0, Val_pretty_default);
ca4e7e14
JI		 1692
1693}
1694
1695/* This implements the tcl command get_pc_reg
1696 * It returns the value of the PC register
1697 *
1698 * Tcl Arguments:
1699 * None
1700 * Tcl Result:
1701 * The value of the pc register.
1702 */
1703
1704static int
1705get_pc_register (clientData, interp, objc, objv)
1706 ClientData clientData;
1707 Tcl_Interp *interp;
1708 int objc;
1709 Tcl_Obj *CONST objv[];
1710{
1711 char buff[64];
1712
1713 sprintf (buff, "0x%llx",(long long) read_register (PC_REGNUM));
1714 Tcl_SetStringObj(result_ptr->obj_ptr, buff, -1);
1715 return TCL_OK;
1716}
1717
1718/* This implements the tcl command "gdb_changed_register_list"
1719 * It takes a list of registers, and returns a list of
1720 * the registers on that list that have changed since the last
1721 * time the proc was called.
1722 *
1723 * Tcl Arguments:
1724 * A list of registers.
1725 * Tcl Result:
1726 * A list of changed registers.
1727 */
1728
1729static int
1730gdb_changed_register_list (clientData, interp, objc, objv)
1731 ClientData clientData;
1732 Tcl_Interp *interp;
1733 int objc;
1734 Tcl_Obj *CONST objv[];
1735{
1736 objc--;
1737 objv++;
1738
1739 return map_arg_registers (objc, objv, register_changed_p, NULL);
1740}
1741
1742static void
1743register_changed_p (regnum, argp)
1744 int regnum;
1745 void *argp; /* Ignored */
1746{
1747 char raw_buffer[MAX_REGISTER_RAW_SIZE];
1748
1749 if (read_relative_register_raw_bytes (regnum, raw_buffer))
1750 return;
1751
1752 if (memcmp (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
4af2d83a 1753 REGISTER_RAW_SIZE (regnum)) == 0)
ca4e7e14
JI		 1754 return;
1755
1756 /* Found a changed register. Save new value and return its number. */
1757
1758 memcpy (&old_regs[REGISTER_BYTE (regnum)], raw_buffer,
4af2d83a 1759 REGISTER_RAW_SIZE (regnum));
ca4e7e14
JI		 1760
1761 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj(regnum));
1762}
1763\f
1764/*
1765 * This section contains the commands that deal with tracepoints:
1766 */
1767
1768/* return a list of all tracepoint numbers in interpreter */
1769static int
1770gdb_get_tracepoint_list (clientData, interp, objc, objv)
1771 ClientData clientData;
1772 Tcl_Interp *interp;
1773 int objc;
1774 Tcl_Obj *CONST objv[];
1775{
1776 struct tracepoint *tp;
1777
1778 Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
1779
1780 ALL_TRACEPOINTS (tp)
1781 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->number));
1782
1783 return TCL_OK;
1784}
1785
1786/* returns -1 if not found, tracepoint # if found */
1787int
1788tracepoint_exists (char * args)
1789{
1790 struct tracepoint *tp;
1791 char **canonical;
1792 struct symtabs_and_lines sals;
1793 char *file = NULL;
1794 int result = -1;
1795
1796 sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
1797 if (sals.nelts == 1)
1798 {
1799 resolve_sal_pc (&sals.sals[0]);
1800 file = xmalloc (strlen (sals.sals[0].symtab->dirname)
1801 + strlen (sals.sals[0].symtab->filename) + 1);
1802 if (file != NULL)
1803 {
1804 strcpy (file, sals.sals[0].symtab->dirname);
1805 strcat (file, sals.sals[0].symtab->filename);
1806
1807 ALL_TRACEPOINTS (tp)
1808 {
1809 if (tp->address == sals.sals[0].pc)
1810 result = tp->number;
1811#if 0
1812 /* Why is this here? This messes up assembly traces */
1813 else if (tp->source_file != NULL
1814 && strcmp (tp->source_file, file) == 0
1815 && sals.sals[0].line == tp->line_number)
1816 result = tp->number;
1817#endif
1818 }
1819 }
1820 }
1821 if (file != NULL)
1822 free (file);
1823 return result;
1824}
1825
1826static int
1827gdb_tracepoint_exists_command (clientData, interp, objc, objv)
1828 ClientData clientData;
1829 Tcl_Interp *interp;
1830 int objc;
1831 Tcl_Obj *CONST objv[];
1832{
1833 char * args;
1834
1835 if (objc != 2)
1836 {
1837 Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
1838 Tcl_GetStringFromObj (objv[0], NULL),
1839 " function:line|function|line|*addr\"", NULL);
1840 return TCL_ERROR;
1841 }
1842
1843 args = Tcl_GetStringFromObj (objv[1], NULL);
1844
1845 Tcl_SetIntObj (result_ptr->obj_ptr, tracepoint_exists (args));
1846 return TCL_OK;
1847}
1848
1849static int
1850gdb_get_tracepoint_info (clientData, interp, objc, objv)
1851 ClientData clientData;
1852 Tcl_Interp *interp;
1853 int objc;
1854 Tcl_Obj *CONST objv[];
1855{
1856 struct symtab_and_line sal;
1857 int tpnum;
1858 struct tracepoint *tp;
1859 struct action_line *al;
1860 Tcl_Obj *action_list;
63d138d9 1861 char *filename, *funcname, *fname;
ca4e7e14
JI		 1862 char tmp[19];
1863
1864 if (objc != 2)
1865 {
1866 Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
1867 return TCL_ERROR;
1868 }
1869
1870 if (Tcl_GetIntFromObj (NULL, objv[1], &tpnum) != TCL_OK)
1871 {
1872 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
1873 return TCL_ERROR;
1874 }
1875
1876 ALL_TRACEPOINTS (tp)
1877 if (tp->number == tpnum)
1878 break;
1879
1880 if (tp == NULL)
1881 {
63d138d9
JI		 1882 char buff[64];
1883 sprintf (buff, "Tracepoint #%d does not exist", tpnum);
1884 Tcl_SetStringObj (result_ptr->obj_ptr, buff, -1);
ca4e7e14
JI		 1885 return TCL_ERROR;
1886 }
1887
1888 Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
1889 sal = find_pc_line (tp->address, 0);
1890 filename = symtab_to_filename (sal.symtab);
1891 if (filename == NULL)
1892 filename = "N/A";
1893 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr,
1894 Tcl_NewStringObj (filename, -1));
63d138d9 1895
ca4e7e14 1896 find_pc_partial_function (tp->address, &funcname, NULL, NULL);
63d138d9
JI		 1897 fname = cplus_demangle (funcname, 0);
1898 if (fname)
1899 {
1900 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewStringObj
1901 (fname, -1));
1902 free (fname);
1903 }
1904 else
1905 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewStringObj
1906 (funcname, -1));
1907
ca4e7e14
JI		 1908 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (sal.line));
1909 sprintf (tmp, "0x%lx", tp->address);
1910 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewStringObj (tmp, -1));
1911 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->enabled));
1912 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->pass_count));
1913 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->step_count));
1914 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->thread));
1915 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, Tcl_NewIntObj (tp->hit_count));
1916
1917 /* Append a list of actions */
1918 action_list = Tcl_NewObj ();
1919 for (al = tp->actions; al != NULL; al = al->next)
1920 {
1921 Tcl_ListObjAppendElement (interp, action_list,
1922 Tcl_NewStringObj (al->action, -1));
1923 }
1924 Tcl_ListObjAppendElement (interp, result_ptr->obj_ptr, action_list);
1925
1926 return TCL_OK;
1927}
1928
1929
1930static int
1931gdb_trace_status (clientData, interp, objc, objv)
1932 ClientData clientData;
1933 Tcl_Interp *interp;
1934 int objc;
1935 Tcl_Obj *CONST objv[];
1936{
1937 int result = 0;
1938
1939 if (trace_running_p)
1940 result = 1;
1941
1942 Tcl_SetIntObj (result_ptr->obj_ptr, result);
1943 return TCL_OK;
1944}
1945
1946
1947
1948static int
1949gdb_get_trace_frame_num (clientData, interp, objc, objv)
1950 ClientData clientData;
1951 Tcl_Interp *interp;
1952 int objc;
1953 Tcl_Obj *CONST objv[];
1954{
1955 if (objc != 1)
1956 {
1957 Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # of args: should be \"",
1958 Tcl_GetStringFromObj (objv[0], NULL),
1959 " linespec\"", NULL);
1960 return TCL_ERROR;
1961 }
1962
1963 Tcl_SetIntObj (result_ptr->obj_ptr, get_traceframe_number ());
1964 return TCL_OK;
1965
1966}
1967
1968/* This implements the tcl command gdb_actions
1969 * It sets actions for a given tracepoint.
1970 *
1971 * Tcl Arguments:
1972 * number: the tracepoint in question
1973 * actions: the actions to add to this tracepoint
1974 * Tcl Result:
1975 * None.
1976 */
1977
1978static int
1979gdb_actions_command (clientData, interp, objc, objv)
1980 ClientData clientData;
1981 Tcl_Interp *interp;
1982 int objc;
1983 Tcl_Obj *CONST objv[];
1984{
1985 struct tracepoint *tp;
1986 Tcl_Obj **actions;
1987 int nactions, i, len;
1988 char *number, *args, *action;
1989 long step_count;
1990 struct action_line *next = NULL, *temp;
1991 enum actionline_type linetype;
1992
1993 if (objc != 3)
1994 {
1995 Tcl_AppendStringsToObj (result_ptr->obj_ptr, "wrong # args: should be: \"",
1996 Tcl_GetStringFromObj (objv[0], NULL),
1997 " number actions\"", NULL);
1998 return TCL_ERROR;
1999 }
2000
2001 args = number = Tcl_GetStringFromObj (objv[1], NULL);
2002 tp = get_tracepoint_by_number (&args);
2003 if (tp == NULL)
2004 {
2005 Tcl_AppendStringsToObj (result_ptr->obj_ptr, "Tracepoint \"", number, "\" does not exist", NULL);
2006 return TCL_ERROR;
2007 }
2008
2009 /* Free any existing actions */
2010 if (tp->actions != NULL)
2011 free_actions (tp);
2012
2013 step_count = 0;
2014
2015 Tcl_ListObjGetElements (interp, objv[2], &nactions, &actions);
2016
2017 /* Add the actions to the tracepoint */
2018 for (i = 0; i < nactions; i++)
2019 {
2020 temp = xmalloc (sizeof (struct action_line));
2021 temp->next = NULL;
2022 action = Tcl_GetStringFromObj (actions[i], &len);
2023 temp->action = savestring (action, len);
2024
2025 linetype = validate_actionline (&(temp->action), tp);
2026
2027 if (linetype == BADLINE)
2028 {
2029 free (temp);
2030 continue;
2031 }
2032
2033 if (next == NULL)
2034 {
2035 tp->actions = temp;
2036 next = temp;
2037 }
2038 else
2039 {
2040 next->next = temp;
2041 next = temp;
2042 }
2043 }
2044
2045 return TCL_OK;
2046}
2047\f
2048/*
2049 * This section has commands that handle source disassembly.
2050 */
2051
2052/* This implements the tcl command gdb_disassemble
2053 *
2054 * Arguments:
2055 * source_with_assm - must be "source" or "nosource"
2056 * low_address - the address from which to start disassembly
2057 * ?hi_address? - the address to which to disassemble, defaults
2058 * to the end of the function containing low_address.
2059 * Tcl Result:
2060 * The disassembled code is passed to fputs_unfiltered, so it
2061 * either goes to the console if result_ptr->obj_ptr is NULL or to
2062 * the Tcl result.
2063 */
2064
2065static int
2066gdb_disassemble (clientData, interp, objc, objv)
2067 ClientData clientData;
2068 Tcl_Interp *interp;
2069 int objc;
2070 Tcl_Obj *CONST objv[];
2071{
2072 CORE_ADDR pc, low, high;
2073 int mixed_source_and_assembly;
2074 static disassemble_info di;
2075 static int di_initialized;
2076 char *arg_ptr;
2077
2078 if (objc != 3 && objc != 4)
2079 error ("wrong # args");
2080
2081 if (! di_initialized)
2082 {
2083 INIT_DISASSEMBLE_INFO_NO_ARCH (di, gdb_stdout,
4af2d83a 2084 (fprintf_ftype) fprintf_unfiltered);
ca4e7e14
JI		 2085 di.flavour = bfd_target_unknown_flavour;
2086 di.memory_error_func = dis_asm_memory_error;
2087 di.print_address_func = dis_asm_print_address;
2088 di_initialized = 1;
2089 }
2090
f0b51514 2091 di.mach = TARGET_PRINT_INSN_INFO->mach;
ca4e7e14
JI		 2092 if (TARGET_BYTE_ORDER == BIG_ENDIAN)
2093 di.endian = BFD_ENDIAN_BIG;
2094 else
2095 di.endian = BFD_ENDIAN_LITTLE;
2096
2097 arg_ptr = Tcl_GetStringFromObj (objv[1], NULL);
2098 if (*arg_ptr == 's' && strcmp (arg_ptr, "source") == 0)
2099 mixed_source_and_assembly = 1;
2100 else if (*arg_ptr == 'n' && strcmp (arg_ptr, "nosource") == 0)
2101 mixed_source_and_assembly = 0;
2102 else
2103 error ("First arg must be 'source' or 'nosource'");
2104
2105 low = parse_and_eval_address (Tcl_GetStringFromObj (objv[2], NULL));
2106
2107 if (objc == 3)
2108 {
2109 if (find_pc_partial_function (low, NULL, &low, &high) == 0)
4af2d83a 2110 error ("No function contains specified address");
ca4e7e14
JI		 2111 }
2112 else
2113 high = parse_and_eval_address (Tcl_GetStringFromObj (objv[3], NULL));
2114
2115 /* If disassemble_from_exec == -1, then we use the following heuristic to
2116 determine whether or not to do disassembly from target memory or from the
2117 exec file:
2118
2119 If we're debugging a local process, read target memory, instead of the
2120 exec file. This makes disassembly of functions in shared libs work
2121 correctly.
2122
2123 Else, we're debugging a remote process, and should disassemble from the
2124 exec file for speed. However, this is no good if the target modifies its
2125 code (for relocation, or whatever).
2126 */
2127
2128 if (disassemble_from_exec == -1)
6f5af15b
MH		 2129 {
2130 if (strcmp (target_shortname, "child") == 0
4af2d83a
KS		 2131 || strcmp (target_shortname, "procfs") == 0
2132 || strcmp (target_shortname, "vxprocess") == 0)
2133 disassemble_from_exec = 0; /* It's a child process, read inferior mem */
6f5af15b 2134 else
4af2d83a 2135 disassemble_from_exec = 1; /* It's remote, read the exec file */
6f5af15b 2136 }
ca4e7e14
JI		 2137
2138 if (disassemble_from_exec)
2139 di.read_memory_func = gdbtk_dis_asm_read_memory;
2140 else
2141 di.read_memory_func = dis_asm_read_memory;
2142
2143 /* If just doing straight assembly, all we need to do is disassemble
2144 everything between low and high. If doing mixed source/assembly, we've
2145 got a totally different path to follow. */
2146
2147 if (mixed_source_and_assembly)
2148 { /* Come here for mixed source/assembly */
2149 /* The idea here is to present a source-O-centric view of a function to
4af2d83a
KS		 2150 the user. This means that things are presented in source order, with
2151 (possibly) out of order assembly immediately following. */
ca4e7e14
JI		 2152 struct symtab *symtab;
2153 struct linetable_entry *le;
2154 int nlines;
2155 int newlines;
2156 struct my_line_entry *mle;
2157 struct symtab_and_line sal;
2158 int i;
2159 int out_of_order;
2160 int next_line;
2161
2162 symtab = find_pc_symtab (low); /* Assume symtab is valid for whole PC range */
2163
d0757953 2164 if (!symtab || !symtab->linetable)
4af2d83a 2165 goto assembly_only;
ca4e7e14 2166
4af2d83a 2167 /* First, convert the linetable to a bunch of my_line_entry's. */
ca4e7e14
JI		 2168
2169 le = symtab->linetable->item;
2170 nlines = symtab->linetable->nitems;
2171
2172 if (nlines <= 0)
4af2d83a 2173 goto assembly_only;
ca4e7e14
JI		 2174
2175 mle = (struct my_line_entry *) alloca (nlines * sizeof (struct my_line_entry));
2176
2177 out_of_order = 0;
4af2d83a
KS		 2178
2179 /* Copy linetable entries for this function into our data structure, creating
2180 end_pc's and setting out_of_order as appropriate. */
ca4e7e14 2181
4af2d83a 2182 /* First, skip all the preceding functions. */
ca4e7e14
JI		 2183
2184 for (i = 0; i < nlines - 1 && le[i].pc < low; i++) ;
2185
4af2d83a 2186 /* Now, copy all entries before the end of this function. */
ca4e7e14
JI		 2187
2188 newlines = 0;
2189 for (; i < nlines - 1 && le[i].pc < high; i++)
4af2d83a
KS		 2190 {
2191 if (le[i].line == le[i + 1].line
2192 && le[i].pc == le[i + 1].pc)
2193 continue; /* Ignore duplicates */
2194
2195 mle[newlines].line = le[i].line;
2196 if (le[i].line > le[i + 1].line)
2197 out_of_order = 1;
2198 mle[newlines].start_pc = le[i].pc;
2199 mle[newlines].end_pc = le[i + 1].pc;
2200 newlines++;
2201 }
2202
2203 /* If we're on the last line, and it's part of the function, then we need to
2204 get the end pc in a special way. */
ca4e7e14
JI		 2205
2206 if (i == nlines - 1
4af2d83a
KS		 2207 && le[i].pc < high)
2208 {
2209 mle[newlines].line = le[i].line;
2210 mle[newlines].start_pc = le[i].pc;
2211 sal = find_pc_line (le[i].pc, 0);
2212 mle[newlines].end_pc = sal.end;
2213 newlines++;
2214 }
ca4e7e14 2215
4af2d83a 2216 /* Now, sort mle by line #s (and, then by addresses within lines). */
ca4e7e14
JI		 2217
2218 if (out_of_order)
4af2d83a 2219 qsort (mle, newlines, sizeof (struct my_line_entry), compare_lines);
ca4e7e14 2220
4af2d83a
KS		 2221 /* Now, for each line entry, emit the specified lines (unless they have been
2222 emitted before), followed by the assembly code for that line. */
ca4e7e14
JI		 2223
2224 next_line = 0; /* Force out first line */
2225 for (i = 0; i < newlines; i++)
4af2d83a
KS		 2226 {
2227 /* Print out everything from next_line to the current line. */
2228
2229 if (mle[i].line >= next_line)
2230 {
2231 if (next_line != 0)
2232 print_source_lines (symtab, next_line, mle[i].line + 1, 0);
2233 else
2234 print_source_lines (symtab, mle[i].line, mle[i].line + 1, 0);
2235
2236 next_line = mle[i].line + 1;
2237 }
2238
2239 for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
2240 {
2241 QUIT;
2242 fputs_unfiltered (" ", gdb_stdout);
2243 print_address (pc, gdb_stdout);
2244 fputs_unfiltered (":\t ", gdb_stdout);
2245 pc += (*tm_print_insn) (pc, &di);
2246 fputs_unfiltered ("\n", gdb_stdout);
2247 }
2248 }
ca4e7e14
JI		 2249 }
2250 else
2251 {
4af2d83a 2252 assembly_only:
ca4e7e14 2253 for (pc = low; pc < high; )
4af2d83a
KS		 2254 {
2255 QUIT;
2256 fputs_unfiltered (" ", gdb_stdout);
2257 print_address (pc, gdb_stdout);
2258 fputs_unfiltered (":\t ", gdb_stdout);
2259 pc += (*tm_print_insn) (pc, &di);
2260 fputs_unfiltered ("\n", gdb_stdout);
2261 }
ca4e7e14
JI		 2262 }
2263
2264 gdb_flush (gdb_stdout);
2265
2266 return TCL_OK;
2267}
2268
2269/* This is the memory_read_func for gdb_disassemble when we are
2270 disassembling from the exec file. */
2271
2272static int
2273gdbtk_dis_asm_read_memory (memaddr, myaddr, len, info)
2274 bfd_vma memaddr;
2275 bfd_byte *myaddr;
2276 int len;
2277 disassemble_info *info;
2278{
2279 extern struct target_ops exec_ops;
2280 int res;
2281
2282 errno = 0;
2283 res = xfer_memory (memaddr, myaddr, len, 0, &exec_ops);
2284
2285 if (res == len)
2286 return 0;
2287 else
2288 if (errno == 0)
2289 return EIO;
2290 else
2291 return errno;
2292}
2293
2294/* This will be passed to qsort to sort the results of the disassembly */
2295
2296static int
2297compare_lines (mle1p, mle2p)
2298 const PTR mle1p;
2299 const PTR mle2p;
2300{
2301 struct my_line_entry *mle1, *mle2;
2302 int val;
2303
2304 mle1 = (struct my_line_entry *) mle1p;
2305 mle2 = (struct my_line_entry *) mle2p;
2306
2307 val = mle1->line - mle2->line;
2308
2309 if (val != 0)
2310 return val;
2311
2312 return mle1->start_pc - mle2->start_pc;
2313}
2314
2315/* This implements the TCL command `gdb_loc',
2316 *
2317 * Arguments:
2318 * ?symbol? The symbol or address to locate - defaults to pc
2319 * Tcl Return:
2320 * a list consisting of the following:
2321 * basename, function name, filename, line number, address, current pc
2322 */
2323
2324static int
2325gdb_loc (clientData, interp, objc, objv)
2326 ClientData clientData;
2327 Tcl_Interp *interp;
2328 int objc;
2329 Tcl_Obj *CONST objv[];
2330{
2331 char *filename;
2332 struct symtab_and_line sal;
2333 char *funcname, *fname;
2334 CORE_ADDR pc;
2335
2336 if (!have_full_symbols () && !have_partial_symbols ())
2337 {
2338 Tcl_SetStringObj (result_ptr->obj_ptr, "No symbol table is loaded", -1);
2339 return TCL_ERROR;
2340 }
2341
2342 if (objc == 1)
2343 {
2344 if (selected_frame && (selected_frame->pc != stop_pc))
4af2d83a
KS		 2345 {
2346 /* Note - this next line is not correct on all architectures. */
2347 /* For a graphical debugger we really want to highlight the */
2348 /* assembly line that called the next function on the stack. */
2349 /* Many architectures have the next instruction saved as the */
2350 /* pc on the stack, so what happens is the next instruction is hughlighted. */
2351 /* FIXME */
2352 pc = selected_frame->pc;
2353 sal = find_pc_line (selected_frame->pc,
2354 selected_frame->next != NULL
2355 && !selected_frame->next->signal_handler_caller
2356 && !frame_in_dummy (selected_frame->next));
2357 }
ca4e7e14 2358 else
4af2d83a
KS		 2359 {
2360 pc = stop_pc;
2361 sal = find_pc_line (stop_pc, 0);
2362 }
ca4e7e14
JI		 2363 }
2364 else if (objc == 2)
2365 {
2366 struct symtabs_and_lines sals;
2367 int nelts;
2368
2369 sals = decode_line_spec (Tcl_GetStringFromObj (objv[1], NULL), 1);
2370
2371 nelts = sals.nelts;
2372 sal = sals.sals[0];
2373 free (sals.sals);
2374
2375 if (sals.nelts != 1)
4af2d83a
KS		 2376 {
2377 Tcl_SetStringObj (result_ptr->obj_ptr, "Ambiguous line spec", -1);
2378 return TCL_ERROR;
2379 }
ca4e7e14
JI		 2380 pc = sal.pc;
2381 }
2382 else
2383 {
2384 Tcl_SetStringObj (result_ptr->obj_ptr, "wrong # args", -1);
2385 return TCL_ERROR;
2386 }
2387
2388 if (sal.symtab)
2389 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
2390 Tcl_NewStringObj (sal.symtab->filename, -1));
2391 else
2392 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewStringObj ("", 0));
2393
2394 find_pc_partial_function (pc, &funcname, NULL, NULL);
2395 fname = cplus_demangle (funcname, 0);
2396 if (fname)
2397 {
2398 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
2399 Tcl_NewStringObj (fname, -1));
2400 free (fname);
2401 }
2402 else
2403 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
2404 Tcl_NewStringObj (funcname, -1));
2405
2406 filename = symtab_to_filename (sal.symtab);
2407 if (filename == NULL)
2408 filename = "";
2409
2410 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
2411 Tcl_NewStringObj (filename, -1));
2412 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj(sal.line)); /* line number */
2413 sprintf_append_element_to_obj (result_ptr->obj_ptr, "0x%s", paddr_nz(pc)); /* PC in current frame */
2414 sprintf_append_element_to_obj (result_ptr->obj_ptr, "0x%s", paddr_nz(stop_pc)); /* Real PC */
2415 return TCL_OK;
2416}
2417
2418/* This implements the Tcl command 'gdb_get_mem', which
2419 * dumps a block of memory
2420 * Arguments:
2421 * gdb_get_mem addr form size num aschar
2422 *
2423 * addr: address of data to dump
2424 * form: a char indicating format
2425 * size: size of each element; 1,2,4, or 8 bytes
2426 * num: the number of bytes to read
2427 * acshar: an optional ascii character to use in ASCII dump
2428 *
2429 * Return:
2430 * a list of elements followed by an optional ASCII dump
2431 */
2432
2433static int
2434gdb_get_mem (clientData, interp, objc, objv)
2435 ClientData clientData;
2436 Tcl_Interp *interp;
2437 int objc;
2438 Tcl_Obj *CONST objv[];
2439{
2440 int size, asize, i, j, bc;
2441 CORE_ADDR addr;
2442 int nbytes, rnum, bpr;
2443 long tmp;
6f5af15b 2444 char format, c, buff[128], aschar, *mbuf, *mptr, *cptr, *bptr;
ca4e7e14
JI		 2445 struct type *val_type;
2446
2447 if (objc < 6 || objc > 7)
2448 {
2449 Tcl_SetStringObj (result_ptr->obj_ptr,
2450 "addr format size bytes bytes_per_row ?ascii_char?", -1);
2451 return TCL_ERROR;
2452 }
2453
2454 if (Tcl_GetIntFromObj (interp, objv[3], &size) != TCL_OK)
2455 {
2456 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
2457 return TCL_ERROR;
2458 }
2459 else if (size <= 0)
2460 {
2461 Tcl_SetStringObj (result_ptr->obj_ptr, "Invalid size, must be > 0", -1);
2462 return TCL_ERROR;
2463 }
2464
2465 if (Tcl_GetIntFromObj (interp, objv[4], &nbytes) != TCL_OK)
2466 {
2467 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
2468 return TCL_ERROR;
2469 }
2470 else if (size <= 0)
2471 {
2472 Tcl_SetStringObj (result_ptr->obj_ptr, "Invalid number of bytes, must be > 0",
2473 -1);
2474 return TCL_ERROR;
2475 }
2476
2477 if (Tcl_GetIntFromObj (interp, objv[5], &bpr) != TCL_OK)
2478 {
2479 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
2480 return TCL_ERROR;
2481 }
2482 else if (size <= 0)
2483 {
2484 Tcl_SetStringObj (result_ptr->obj_ptr, "Invalid bytes per row, must be > 0", -1);
2485 return TCL_ERROR;
2486 }
2487
2488 if (Tcl_GetLongFromObj (interp, objv[1], &tmp) != TCL_OK)
2489 return TCL_OK;
2490
2491 addr = (CORE_ADDR) tmp;
2492
2493 format = *(Tcl_GetStringFromObj (objv[2], NULL));
2494 mbuf = (char *)malloc (nbytes+32);
2495 if (!mbuf)
2496 {
2497 Tcl_SetStringObj (result_ptr->obj_ptr, "Out of memory.", -1);
2498 return TCL_ERROR;
2499 }
2500
2501 memset (mbuf, 0, nbytes+32);
2502 mptr = cptr = mbuf;
2503
2504 rnum = target_read_memory_partial (addr, mbuf, nbytes, NULL);
2505
2506 if (objc == 7)
2507 aschar = *(Tcl_GetStringFromObj(objv[6], NULL));
2508 else
2509 aschar = 0;
2510
2511 switch (size) {
2512 case 1:
2513 val_type = builtin_type_char;
2514 asize = 'b';
2515 break;
2516 case 2:
2517 val_type = builtin_type_short;
2518 asize = 'h';
2519 break;
2520 case 4:
2521 val_type = builtin_type_int;
2522 asize = 'w';
2523 break;
2524 case 8:
2525 val_type = builtin_type_long_long;
2526 asize = 'g';
2527 break;
2528 default:
2529 val_type = builtin_type_char;
2530 asize = 'b';
2531 }
2532
2533 bc = 0; /* count of bytes in a row */
2534 buff[0] = '"'; /* buffer for ascii dump */
2535 bptr = &buff[1]; /* pointer for ascii dump */
2536
2537 result_ptr->flags |= GDBTK_MAKES_LIST; /* Build up the result as a list... */
2538
2539 for (i=0; i < nbytes; i+= size)
2540 {
2541 if ( i >= rnum)
4af2d83a
KS		 2542 {
2543 fputs_unfiltered ("N/A ", gdb_stdout);
2544 if (aschar)
2545 for ( j = 0; j < size; j++)
2546 *bptr++ = 'X';
2547 }
ca4e7e14 2548 else
4af2d83a
KS		 2549 {
2550 print_scalar_formatted (mptr, val_type, format, asize, gdb_stdout);
2551
2552 if (aschar)
2553 {
2554 for ( j = 0; j < size; j++)
2555 {
2556 c = *cptr++;
2557 if (c < 32 || c > 126)
2558 c = aschar;
2559 if (c == '"')
2560 *bptr++ = '\\';
2561 *bptr++ = c;
2562 }
2563 }
2564 }
ca4e7e14
JI		 2565
2566 mptr += size;
2567 bc += size;
2568
2569 if (aschar && (bc >= bpr))
4af2d83a
KS		 2570 {
2571 /* end of row. print it and reset variables */
2572 bc = 0;
2573 *bptr++ = '"';
2574 *bptr++ = ' ';
2575 *bptr = 0;
2576 fputs_unfiltered (buff, gdb_stdout);
2577 bptr = &buff[1];
2578 }
ca4e7e14
JI		 2579 }
2580
2581 result_ptr->flags &= ~GDBTK_MAKES_LIST;
2582
2583 free (mbuf);
2584 return TCL_OK;
2585}
2586
2587\f
2588
2589/* This implements the tcl command "gdb_loadfile"
2590 * It loads a c source file into a text widget.
2591 *
2592 * Tcl Arguments:
2593 * widget: the name of the text widget to fill
2594 * filename: the name of the file to load
2595 * linenumbers: A boolean indicating whether or not to display line numbers.
2596 * Tcl Result:
2597 *
2598 */
2599
2600/* In this routine, we will build up a "line table", i.e. a
2601 * table of bits showing which lines in the source file are executible.
2602 * LTABLE_SIZE is the number of bytes to allocate for the line table.
2603 *
2604 * Its size limits the maximum number of lines
2605 * in a file to 8 * LTABLE_SIZE. This memory is freed after
2606 * the file is loaded, so it is OK to make this very large.
2607 * Additional memory will be allocated if needed. */
2608#define LTABLE_SIZE 20000
2609static int
2610gdb_loadfile (clientData, interp, objc, objv)
2611 ClientData clientData;
2612 Tcl_Interp *interp;
2613 int objc;
2614 Tcl_Obj *CONST objv[];
2615{
6f5af15b
MH		 2616 char *file, *widget;
2617 int linenumbers, ln, lnum, ltable_size;
ca4e7e14
JI		 2618 FILE *fp;
2619 char *ltable;
2620 struct symtab *symtab;
2621 struct linetable_entry *le;
2622 long mtime = 0;
2623 struct stat st;
2624 Tcl_DString text_cmd_1, text_cmd_2, *cur_cmd;
2625 char line[1024], line_num_buf[16];
2626 int prefix_len_1, prefix_len_2, cur_prefix_len, widget_len;
2627
2628
2629 if (objc != 4)
2630 {
2631 Tcl_WrongNumArgs(interp, 1, objv, "widget filename linenumbers");
2632 return TCL_ERROR;
2633 }
2634
2635 widget = Tcl_GetStringFromObj (objv[1], NULL);
2636 if ( Tk_NameToWindow (interp, widget, Tk_MainWindow (interp)) == NULL)
2637 {
2638 return TCL_ERROR;
2639 }
2640
2641 file = Tcl_GetStringFromObj (objv[2], NULL);
2642 Tcl_GetBooleanFromObj (interp, objv[3], &linenumbers);
2643
ca4e7e14
JI		 2644 symtab = full_lookup_symtab (file);
2645 if (!symtab)
2646 {
973b0216 2647 Tcl_SetStringObj ( result_ptr->obj_ptr, "File not found in symtab", -1);
ca4e7e14
JI		 2648 fclose (fp);
2649 return TCL_ERROR;
2650 }
2651
973b0216
MH		 2652 file = symtab_to_filename ( symtab );
2653 if ((fp = fopen ( file, "r" )) == NULL)
2654 {
2655 Tcl_SetStringObj ( result_ptr->obj_ptr, "Can't open file for reading", -1);
2656 return TCL_ERROR;
2657 }
2658
ca4e7e14
JI		 2659 if (stat (file, &st) < 0)
2660 {
2661 catch_errors (perror_with_name_wrapper, "gdbtk: get time stamp", "",
2662 RETURN_MASK_ALL);
2663 return TCL_ERROR;
2664 }
2665
2666 if (symtab && symtab->objfile && symtab->objfile->obfd)
2667 mtime = bfd_get_mtime(symtab->objfile->obfd);
2668 else if (exec_bfd)
2669 mtime = bfd_get_mtime(exec_bfd);
2670
2671 if (mtime && mtime < st.st_mtime)
2672 gdbtk_ignorable_warning("Source file is more recent than executable.\n");
2673
2674
2675 /* Source linenumbers don't appear to be in order, and a sort is */
2676 /* too slow so the fastest solution is just to allocate a huge */
2677 /* array and set the array entry for each linenumber */
2678
2679 ltable_size = LTABLE_SIZE;
2680 ltable = (char *)malloc (LTABLE_SIZE);
2681 if (ltable == NULL)
2682 {
2683 Tcl_SetStringObj ( result_ptr->obj_ptr, "Out of memory.", -1);
2684 fclose (fp);
2685 return TCL_ERROR;
2686 }
2687
2688 memset (ltable, 0, LTABLE_SIZE);
2689
2690 if (symtab->linetable && symtab->linetable->nitems)
2691 {
2692 le = symtab->linetable->item;
2693 for (ln = symtab->linetable->nitems ;ln > 0; ln--, le++)
4af2d83a
KS		 2694 {
2695 lnum = le->line >> 3;
2696 if (lnum >= ltable_size)
2697 {
2698 char *new_ltable;
2699 new_ltable = (char *)realloc (ltable, ltable_size*2);
2700 memset (new_ltable + ltable_size, 0, ltable_size);
2701 ltable_size *= 2;
2702 if (new_ltable == NULL)
2703 {
2704 Tcl_SetStringObj ( result_ptr->obj_ptr, "Out of memory.", -1);
2705 free (ltable);
2706 fclose (fp);
2707 return TCL_ERROR;
2708 }
2709 ltable = new_ltable;
2710 }
2711 ltable[lnum] |= 1 << (le->line % 8);
2712 }
ca4e7e14
JI		 2713 }
2714
2715 Tcl_DStringInit(&text_cmd_1);
2716 Tcl_DStringInit(&text_cmd_2);
2717
2718 ln = 1;
2719
2720 widget_len = strlen (widget);
2721 line[0] = '\t';
2722
2723 Tcl_DStringAppend (&text_cmd_1, widget, widget_len);
2724 Tcl_DStringAppend (&text_cmd_2, widget, widget_len);
2725
2726 if (linenumbers)
2727 {
2728 Tcl_DStringAppend (&text_cmd_1, " insert end {-\t", -1);
2729 prefix_len_1 = Tcl_DStringLength(&text_cmd_1);
2730
2731 Tcl_DStringAppend (&text_cmd_2, " insert end { \t", -1);
2732 prefix_len_2 = Tcl_DStringLength(&text_cmd_2);
2733
2734 while (fgets (line + 1, 980, fp))
4af2d83a
KS		 2735 {
2736 sprintf (line_num_buf, "%d", ln);
2737 if (ltable[ln >> 3] & (1 << (ln % 8)))
2738 {
2739 cur_cmd = &text_cmd_1;
2740 cur_prefix_len = prefix_len_1;
2741 Tcl_DStringAppend (cur_cmd, line_num_buf, -1);
63d138d9 2742 Tcl_DStringAppend (cur_cmd, "} break_rgn_tag", 15);
4af2d83a
KS		 2743 }
2744 else
2745 {
2746 cur_cmd = &text_cmd_2;
2747 cur_prefix_len = prefix_len_2;
2748 Tcl_DStringAppend (cur_cmd, line_num_buf, -1);
2749 Tcl_DStringAppend (cur_cmd, "} \"\"", 4);
2750 }
2751
2752 Tcl_DStringAppendElement (cur_cmd, line);
2753 Tcl_DStringAppend (cur_cmd, " source_tag", 11);
2754
2755 Tcl_Eval(interp, Tcl_DStringValue(cur_cmd));
2756 Tcl_DStringSetLength(cur_cmd, cur_prefix_len);
2757 ln++;
2758 }
ca4e7e14
JI		 2759 }
2760 else
2761 {
63d138d9 2762 Tcl_DStringAppend (&text_cmd_1, " insert end {- } break_rgn_tag", -1);
ca4e7e14 2763 prefix_len_1 = Tcl_DStringLength(&text_cmd_1);
6e778194 2764 Tcl_DStringAppend (&text_cmd_2, " insert end { } \"\"", -1);
ca4e7e14
JI		 2765 prefix_len_2 = Tcl_DStringLength(&text_cmd_2);
2766
ca4e7e14 2767 while (fgets (line + 1, 980, fp))
4af2d83a
KS		 2768 {
2769 if (ltable[ln >> 3] & (1 << (ln % 8)))
2770 {
2771 cur_cmd = &text_cmd_1;
2772 cur_prefix_len = prefix_len_1;
2773 }
2774 else
2775 {
2776 cur_cmd = &text_cmd_2;
2777 cur_prefix_len = prefix_len_2;
2778 }
2779
2780 Tcl_DStringAppendElement (cur_cmd, line);
2781 Tcl_DStringAppend (cur_cmd, " source_tag", 11);
2782
2783 Tcl_Eval(interp, Tcl_DStringValue(cur_cmd));
2784 Tcl_DStringSetLength(cur_cmd, cur_prefix_len);
2785
2786 ln++;
2787 }
ca4e7e14
JI		 2788 }
2789
2790 Tcl_DStringFree (&text_cmd_1);
2791 Tcl_DStringFree (&text_cmd_2);
2792 free (ltable);
2793 fclose (fp);
2794 return TCL_OK;
2795}
2796\f
2797/*
2798 * This section contains commands for manipulation of breakpoints.
2799 */
2800
2801
2802/* set a breakpoint by source file and line number */
2803/* flags are as follows: */
2804/* least significant 2 bits are disposition, rest is */
2805/* type (normally 0).
2806
2807enum bptype {
2808 bp_breakpoint, Normal breakpoint
2809 bp_hardware_breakpoint, Hardware assisted breakpoint
2810}
2811
2812Disposition of breakpoint. Ie: what to do after hitting it.
2813enum bpdisp {
2814 del, Delete it
2815 del_at_next_stop, Delete at next stop, whether hit or not
2816 disable, Disable it
2817 donttouch Leave it alone
2818 };
2819*/
2820
2821/* This implements the tcl command "gdb_set_bp"
2822 * It sets breakpoints, and runs the Tcl command
2823 * gdbtk_tcl_breakpoint create
2824 * to register the new breakpoint with the GUI.
2825 *
2826 * Tcl Arguments:
2827 * filename: the file in which to set the breakpoint
2828 * line: the line number for the breakpoint
2829 * type: the type of the breakpoint
d84563bc 2830 * thread: optional thread number
ca4e7e14
JI		 2831 * Tcl Result:
2832 * The return value of the call to gdbtk_tcl_breakpoint.
2833 */
2834
2835static int
2836gdb_set_bp (clientData, interp, objc, objv)
2837 ClientData clientData;
2838 Tcl_Interp *interp;
2839 int objc;
2840 Tcl_Obj *CONST objv[];
2841
2842{
2843 struct symtab_and_line sal;
d84563bc 2844 int line, flags, ret, thread = -1;
ca4e7e14
JI		 2845 struct breakpoint *b;
2846 char buf[64];
2847 Tcl_DString cmd;
2848
d84563bc 2849 if (objc != 4 && objc != 5)
ca4e7e14 2850 {
d84563bc 2851 Tcl_WrongNumArgs(interp, 1, objv, "filename line type [thread]");
ca4e7e14
JI		 2852 return TCL_ERROR;
2853 }
2854
2855 sal.symtab = full_lookup_symtab (Tcl_GetStringFromObj( objv[1], NULL));
2856 if (sal.symtab == NULL)
2857 return TCL_ERROR;
2858
2859 if (Tcl_GetIntFromObj( interp, objv[2], &line) == TCL_ERROR)
2860 {
2861 result_ptr->flags = GDBTK_IN_TCL_RESULT;
2862 return TCL_ERROR;
2863 }
2864
2865 if (Tcl_GetIntFromObj( interp, objv[3], &flags) == TCL_ERROR)
2866 {
2867 result_ptr->flags = GDBTK_IN_TCL_RESULT;
2868 return TCL_ERROR;
2869 }
2870
d84563bc
MH		 2871 if (objc == 5)
2872 {
2873 if (Tcl_GetIntFromObj( interp, objv[4], &thread) == TCL_ERROR)
2874 {
2875 result_ptr->flags = GDBTK_IN_TCL_RESULT;
2876 return TCL_ERROR;
2877 }
2878 }
2879
ca4e7e14
JI		 2880 sal.line = line;
2881 if (!find_line_pc (sal.symtab, sal.line, &sal.pc))
2882 return TCL_ERROR;
2883
2884 sal.section = find_pc_overlay (sal.pc);
2885 b = set_raw_breakpoint (sal);
2886 set_breakpoint_count (breakpoint_count + 1);
2887 b->number = breakpoint_count;
2888 b->type = flags >> 2;
2889 b->disposition = flags & 3;
d84563bc 2890 b->thread = thread;
ca4e7e14
JI		 2891
2892 /* FIXME: this won't work for duplicate basenames! */
2893 sprintf (buf, "%s:%d", basename (Tcl_GetStringFromObj ( objv[1], NULL)), line);
2894 b->addr_string = strsave (buf);
2895
2896 /* now send notification command back to GUI */
2897
2898 Tcl_DStringInit (&cmd);
2899
2900 Tcl_DStringAppend (&cmd, "gdbtk_tcl_breakpoint create ", -1);
2901 sprintf (buf, "%d", b->number);
2902 Tcl_DStringAppendElement(&cmd, buf);
6f5af15b 2903 sprintf (buf, "0x%lx", (long)sal.pc);
ca4e7e14
JI		 2904 Tcl_DStringAppendElement (&cmd, buf);
2905 Tcl_DStringAppendElement (&cmd, Tcl_GetStringFromObj (objv[2], NULL));
2906 Tcl_DStringAppendElement (&cmd, Tcl_GetStringFromObj (objv[1], NULL));
63d138d9
JI		 2907 Tcl_DStringAppendElement (&cmd, bpdisp[b->disposition]);
2908 sprintf (buf, "%d", b->enable);
2909 Tcl_DStringAppendElement (&cmd, buf);
2910 sprintf (buf, "%d", b->thread);
2911 Tcl_DStringAppendElement (&cmd, buf);
2912
ca4e7e14
JI		 2913
2914 ret = Tcl_Eval (interp, Tcl_DStringValue (&cmd));
2915 Tcl_DStringFree (&cmd);
2916 return ret;
2917}
2918
23e1f78b
MH		 2919/* This implements the tcl command "gdb_set_bp_addr"
2920 * It sets breakpoints, and runs the Tcl command
2921 * gdbtk_tcl_breakpoint create
2922 * to register the new breakpoint with the GUI.
2923 *
2924 * Tcl Arguments:
2925 * addr: the address at which to set the breakpoint
2926 * type: the type of the breakpoint
2927 * thread: optional thread number
2928 * Tcl Result:
2929 * The return value of the call to gdbtk_tcl_breakpoint.
2930 */
2931
2932static int
2933gdb_set_bp_addr (clientData, interp, objc, objv)
2934 ClientData clientData;
2935 Tcl_Interp *interp;
2936 int objc;
2937 Tcl_Obj *CONST objv[];
2938
2939{
2940 struct symtab_and_line sal;
2941 int line, flags, ret, thread = -1;
2942 long addr;
2943 struct breakpoint *b;
5c01b16e 2944 char *filename, buf[64];
23e1f78b
MH		 2945 Tcl_DString cmd;
2946
2947 if (objc != 4 && objc != 3)
2948 {
63d138d9 2949 Tcl_WrongNumArgs(interp, 1, objv, "addr type ?thread?");
23e1f78b
MH		 2950 return TCL_ERROR;
2951 }
2952
2953 if (Tcl_GetLongFromObj( interp, objv[1], &addr) == TCL_ERROR)
2954 {
2955 result_ptr->flags = GDBTK_IN_TCL_RESULT;
2956 return TCL_ERROR;
2957 }
2958
2959 if (Tcl_GetIntFromObj( interp, objv[2], &flags) == TCL_ERROR)
2960 {
2961 result_ptr->flags = GDBTK_IN_TCL_RESULT;
2962 return TCL_ERROR;
2963 }
2964
2965 if (objc == 4)
2966 {
2967 if (Tcl_GetIntFromObj( interp, objv[3], &thread) == TCL_ERROR)
2968 {
2969 result_ptr->flags = GDBTK_IN_TCL_RESULT;
2970 return TCL_ERROR;
2971 }
2972 }
2973
2974 sal = find_pc_line (addr, 0);
2975 sal.pc = addr;
2976 b = set_raw_breakpoint (sal);
2977 set_breakpoint_count (breakpoint_count + 1);
2978 b->number = breakpoint_count;
2979 b->type = flags >> 2;
2980 b->disposition = flags & 3;
2981 b->thread = thread;
2982
2983 sprintf (buf, "*(0x%lx)",addr);
2984 b->addr_string = strsave (buf);
2985
2986 /* now send notification command back to GUI */
2987
2988 Tcl_DStringInit (&cmd);
2989
2990 Tcl_DStringAppend (&cmd, "gdbtk_tcl_breakpoint create ", -1);
2991 sprintf (buf, "%d", b->number);
2992 Tcl_DStringAppendElement(&cmd, buf);
2993 sprintf (buf, "0x%lx", addr);
2994 Tcl_DStringAppendElement (&cmd, buf);
2995 sprintf (buf, "%d", b->line_number);
2996 Tcl_DStringAppendElement (&cmd, buf);
5c01b16e
MH		 2997
2998 filename = symtab_to_filename (sal.symtab);
2999 if (filename == NULL)
3000 filename = "";
3001 Tcl_DStringAppendElement (&cmd, filename);
63d138d9
JI		 3002 Tcl_DStringAppendElement (&cmd, bpdisp[b->disposition]);
3003 sprintf (buf, "%d", b->enable);
3004 Tcl_DStringAppendElement (&cmd, buf);
3005 sprintf (buf, "%d", b->thread);
3006 Tcl_DStringAppendElement (&cmd, buf);
23e1f78b
MH		 3007
3008 ret = Tcl_Eval (interp, Tcl_DStringValue (&cmd));
3009 Tcl_DStringFree (&cmd);
3010 return ret;
3011}
3012
d84563bc
MH		 3013/* This implements the tcl command "gdb_find_bp_at_line"
3014 *
3015 * Tcl Arguments:
3016 * filename: the file in which to find the breakpoint
3017 * line: the line number for the breakpoint
3018 * Tcl Result:
3019 * It returns a list of breakpoint numbers
3020 */
3021
3022static int
3023gdb_find_bp_at_line(clientData, interp, objc, objv)
3024 ClientData clientData;
3025 Tcl_Interp *interp;
3026 int objc;
3027 Tcl_Obj *CONST objv[];
3028
3029{
3030 struct symtab *s;
3031 int line;
3032 struct breakpoint *b;
3033 extern struct breakpoint *breakpoint_chain;
3034
3035 if (objc != 3)
3036 {
3037 Tcl_WrongNumArgs(interp, 1, objv, "filename line");
3038 return TCL_ERROR;
3039 }
3040
3041 s = full_lookup_symtab (Tcl_GetStringFromObj( objv[1], NULL));
3042 if (s == NULL)
3043 return TCL_ERROR;
3044
3045 if (Tcl_GetIntFromObj( interp, objv[2], &line) == TCL_ERROR)
3046 {
3047 result_ptr->flags = GDBTK_IN_TCL_RESULT;
3048 return TCL_ERROR;
3049 }
3050
3051 Tcl_SetListObj (result_ptr->obj_ptr ,0 ,NULL);
3052 for (b = breakpoint_chain; b; b = b->next)
3053 if (b->line_number == line && !strcmp(b->source_file, s->filename))
3054 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
3055 Tcl_NewIntObj (b->number));
3056
3057 return TCL_OK;
3058}
3059
3060
3061/* This implements the tcl command "gdb_find_bp_at_addr"
3062 *
3063 * Tcl Arguments:
3064 * addr: address
3065 * Tcl Result:
3066 * It returns a list of breakpoint numbers
3067 */
3068
3069static int
3070gdb_find_bp_at_addr(clientData, interp, objc, objv)
3071 ClientData clientData;
3072 Tcl_Interp *interp;
3073 int objc;
3074 Tcl_Obj *CONST objv[];
3075
3076{
3077 long addr;
3078 struct breakpoint *b;
3079 extern struct breakpoint *breakpoint_chain;
3080
3081 if (objc != 2)
3082 {
3083 Tcl_WrongNumArgs(interp, 1, objv, "address");
3084 return TCL_ERROR;
3085 }
3086
3087 if (Tcl_GetLongFromObj( interp, objv[1], &addr) == TCL_ERROR)
3088 {
3089 result_ptr->flags = GDBTK_IN_TCL_RESULT;
3090 return TCL_ERROR;
3091 }
3092
3093 Tcl_SetListObj (result_ptr->obj_ptr ,0 ,NULL);
3094 for (b = breakpoint_chain; b; b = b->next)
3095 if (b->address == (CORE_ADDR)addr)
3096 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
3097 Tcl_NewIntObj (b->number));
3098
3099 return TCL_OK;
3100}
3101
ca4e7e14
JI		 3102/* This implements the tcl command gdb_get_breakpoint_info
3103 *
3104 *
3105 * Tcl Arguments:
3106 * breakpoint_number
3107 * Tcl Result:
3108 * A list with {file, function, line_number, address, type, enabled?,
3109 * disposition, ignore_count, {list_of_commands}, thread, hit_count}
3110 */
3111
3112static int
3113gdb_get_breakpoint_info (clientData, interp, objc, objv)
3114 ClientData clientData;
3115 Tcl_Interp *interp;
3116 int objc;
3117 Tcl_Obj *CONST objv[];
3118{
3119 struct symtab_and_line sal;
ca4e7e14
JI		 3120 struct command_line *cmd;
3121 int bpnum;
3122 struct breakpoint *b;
3123 extern struct breakpoint *breakpoint_chain;
3124 char *funcname, *fname, *filename;
3125 Tcl_Obj *new_obj;
3126
3127 if (objc != 2)
3128 {
3129 Tcl_SetStringObj (result_ptr->obj_ptr, "wrong number of args, should be \"breakpoint\"", -1);
3130 return TCL_ERROR;
3131 }
3132
3133 if ( Tcl_GetIntFromObj(NULL, objv[1], &bpnum) != TCL_OK)
3134 {
3135 result_ptr->flags = GDBTK_IN_TCL_RESULT;
3136 return TCL_ERROR;
3137 }
3138
3139 for (b = breakpoint_chain; b; b = b->next)
3140 if (b->number == bpnum)
3141 break;
3142
3143 if (!b || b->type != bp_breakpoint)
3144 {
63d138d9
JI		 3145 char err_buf[64];
3146 sprintf(err_buf, "Breakpoint #%d does not exist.", bpnum);
3147 Tcl_SetStringObj (result_ptr->obj_ptr, err_buf, -1);
ca4e7e14
JI		 3148 return TCL_ERROR;
3149 }
3150
3151 sal = find_pc_line (b->address, 0);
3152
3153 filename = symtab_to_filename (sal.symtab);
3154 if (filename == NULL)
3155 filename = "";
3156
3157 Tcl_SetListObj (result_ptr->obj_ptr ,0 ,NULL);
3158 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
3159 Tcl_NewStringObj (filename, -1));
3160
3161 find_pc_partial_function (b->address, &funcname, NULL, NULL);
3162 fname = cplus_demangle (funcname, 0);
3163 if (fname)
3164 {
3165 new_obj = Tcl_NewStringObj (fname, -1);
3166 free (fname);
3167 }
3168 else
3169 new_obj = Tcl_NewStringObj (funcname, -1);
3170
3171 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, new_obj);
3172
3173 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (b->line_number));
3174 sprintf_append_element_to_obj (result_ptr->obj_ptr, "0x%lx", b->address);
3175 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
3176 Tcl_NewStringObj (bptypes[b->type], -1));
3177 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewBooleanObj(b->enable == enabled));
3178 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
3179 Tcl_NewStringObj (bpdisp[b->disposition], -1));
3180 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (b->ignore_count));
3181
3182 new_obj = Tcl_NewObj();
3183 for (cmd = b->commands; cmd; cmd = cmd->next)
3184 Tcl_ListObjAppendElement (NULL, new_obj,
3185 Tcl_NewStringObj (cmd->line, -1));
3186 Tcl_ListObjAppendElement(NULL, result_ptr->obj_ptr, new_obj);
3187
3188 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr,
3189 Tcl_NewStringObj (b->cond_string, -1));
3190
3191 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (b->thread));
3192 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, Tcl_NewIntObj (b->hit_count));
3193
3194 return TCL_OK;
3195}
3196
3197
3198/* This implements the tcl command gdb_get_breakpoint_list
3199 * It builds up a list of the current breakpoints.
3200 *
3201 * Tcl Arguments:
3202 * None.
3203 * Tcl Result:
3204 * A list of breakpoint numbers.
3205 */
3206
3207static int
3208gdb_get_breakpoint_list (clientData, interp, objc, objv)
3209 ClientData clientData;
3210 Tcl_Interp *interp;
3211 int objc;
3212 Tcl_Obj *CONST objv[];
3213{
3214 struct breakpoint *b;
3215 extern struct breakpoint *breakpoint_chain;
3216 Tcl_Obj *new_obj;
3217
3218 if (objc != 1)
3219 error ("wrong number of args, none are allowed");
3220
3221 for (b = breakpoint_chain; b; b = b->next)
3222 if (b->type == bp_breakpoint)
3223 {
3224 new_obj = Tcl_NewIntObj (b->number);
3225 Tcl_ListObjAppendElement (NULL, result_ptr->obj_ptr, new_obj);
3226 }
3227
3228 return TCL_OK;
3229}
3d64f1e0
KS		 3230\f
3231/* The functions in this section deal with stacks and backtraces. */
3232
3233/* This implements the tcl command gdb_stack.
3234 * It builds up a list of stack frames.
3235 *
3236 * Tcl Arguments:
3237 * start - starting stack frame
3238 * count - number of frames to inspect
3239 * Tcl Result:
3240 * A list of function names
3241 */
3242
3243static int
3244gdb_stack (clientData, interp, objc, objv) ClientData clientData;
3245 Tcl_Interp *interp;
3246 int objc;
3247 Tcl_Obj *CONST objv[];
3248{
3249 int start, count;
3250
3251 if (objc < 3)
3252 {
3253 Tcl_WrongNumArgs (interp, 1, objv, "start count");
3254 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
3255 return TCL_ERROR;
3256 }
3257
3258 if (Tcl_GetIntFromObj (NULL, objv[1], &start))
3259 {
3260 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
3261 return TCL_ERROR;
3262 }
3263 if (Tcl_GetIntFromObj (NULL, objv[2], &count))
3264 {
3265 result_ptr->flags |= GDBTK_IN_TCL_RESULT;
3266 return TCL_ERROR;
3267 }
3268
3269 Tcl_SetListObj (result_ptr->obj_ptr, 0, NULL);
3270
3271 if (target_has_stack)
3272 {
3273 struct frame_info *top;
3274 struct frame_info *fi;
3275
3276 /* Find the outermost frame */
3277 fi = get_current_frame ();
3278 while (fi != NULL)
3279 {
3280 top = fi;
3281 fi = get_prev_frame (fi);
3282 }
3283
3284 /* top now points to the top (outermost frame) of the
3285 stack, so point it to the requested start */
3286 start = -start;
3287 top = find_relative_frame (top, &start);
3288
3289 /* If start != 0, then we have asked to start outputting
3290 frames beyond the innermost stack frame */
3291 if (start == 0)
3292 {
3293 fi = top;
3294 while (fi && count--)
3295 {
3296 get_frame_name (interp, result_ptr->obj_ptr, fi);
3297 fi = get_next_frame (fi);
3298 }
3299 }
3300 }
3301
3302 return TCL_OK;
3303}
3304
3305/* A helper function for get_stack which adds information about
3306 * the stack frame FI to the caller's LIST.
3307 *
3308 * This is stolen from print_frame_info in stack.c.
3309 */
3310static void
3311get_frame_name (interp, list, fi)
3312 Tcl_Interp *interp;
3313 Tcl_Obj *list;
3314 struct frame_info *fi;
3315{
3316 struct symtab_and_line sal;
3317 struct symbol *func = NULL;
3318 register char *funname = 0;
3319 enum language funlang = language_unknown;
3320 Tcl_Obj *objv[1];
3321
3322 if (frame_in_dummy (fi))
3323 {
3324 objv[0] = Tcl_NewStringObj ("<function called from gdb>\n", -1);
3325 Tcl_ListObjAppendElement (interp, list, objv[0]);
3326 return;
3327 }
3328 if (fi->signal_handler_caller)
3329 {
3330 objv[0] = Tcl_NewStringObj ("<signal handler called>\n", -1);
3331 Tcl_ListObjAppendElement (interp, list, objv[0]);
3332 return;
3333 }
3334
3335 sal =
3336 find_pc_line (fi->pc,
3337 fi->next != NULL
3338 && !fi->next->signal_handler_caller
3339 && !frame_in_dummy (fi->next));
3340
3341 func = find_pc_function (fi->pc);
3342 if (func)
3343 {
3344 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
3345 if (msymbol != NULL
3346 && (SYMBOL_VALUE_ADDRESS (msymbol)
3347 > BLOCK_START (SYMBOL_BLOCK_VALUE (func))))
3348 {
3349 func = 0;
3350 funname = SYMBOL_NAME (msymbol);
3351 funlang = SYMBOL_LANGUAGE (msymbol);
3352 }
3353 else
3354 {
3355 funname = SYMBOL_NAME (func);
3356 funlang = SYMBOL_LANGUAGE (func);
3357 }
3358 }
3359 else
3360 {
3361 struct minimal_symbol *msymbol = lookup_minimal_symbol_by_pc (fi->pc);
3362 if (msymbol != NULL)
3363 {
3364 funname = SYMBOL_NAME (msymbol);
3365 funlang = SYMBOL_LANGUAGE (msymbol);
3366 }
3367 }
3368
3369 if (sal.symtab)
3370 {
864e89fc
KS		 3371 char *name = NULL;
3372
3373 if (funlang == language_cplus)
3374 name = cplus_demangle (funname, 0);
3375 if (name == NULL)
3376 name = funname;
3377
3378 objv[0] = Tcl_NewStringObj (name, -1);
3d64f1e0
KS		 3379 Tcl_ListObjAppendElement (interp, list, objv[0]);
3380 }
3381 else
3382 {
3383#if 0
3384 /* we have no convenient way to deal with this yet... */
3385 if (fi->pc != sal.pc || !sal.symtab)
3386 {
3387 print_address_numeric (fi->pc, 1, gdb_stdout);
3388 printf_filtered (" in ");
3389 }
3390 printf_symbol_filtered (gdb_stdout, funname ? funname : "??", funlang,
3391 DMGL_ANSI);
3392#endif
3393 objv[0] = Tcl_NewStringObj (funname != NULL ? funname : "??", -1);
3394#ifdef PC_LOAD_SEGMENT
3395 /* If we couldn't print out function name but if can figure out what
3396 load segment this pc value is from, at least print out some info
3397 about its load segment. */
3398 if (!funname)
3399 {
3400 Tcl_AppendStringsToObj (objv[0], " from ", PC_LOAD_SEGMENT (fi->pc),
3401 (char *) NULL);
3402 }
3403#endif
3404#ifdef PC_SOLIB
3405 if (!funname)
3406 {
3407 char *lib = PC_SOLIB (fi->pc);
3408 if (lib)
3409 {
3410 Tcl_AppendStringsToObj (objv[0], " from ", lib, (char *) NULL);
3411 }
3412 }
3413#endif
3414 Tcl_ListObjAppendElement (interp, list, objv[0]);
3415 }
3416}
ca4e7e14
JI		 3417
3418\f
3419/*
3420 * This section contains a bunch of miscellaneous utility commands
3421 */
3422
3423/* This implements the tcl command gdb_path_conv
3424 *
3425 * On Windows, it canonicalizes the pathname,
3426 * On Unix, it is a no op.
3427 *
3428 * Arguments:
3429 * path
3430 * Tcl Result:
3431 * The canonicalized path.
3432 */
3433
3434static int
3435gdb_path_conv (clientData, interp, objc, objv)
3436 ClientData clientData;
3437 Tcl_Interp *interp;
3438 int objc;
3439 Tcl_Obj *CONST objv[];
3440{
3441 if (objc != 2)
3442 error ("wrong # args");
3443
d836385e 3444#ifdef __CYGWIN__
ca4e7e14
JI		 3445 {
3446 char pathname[256], *ptr;
3447
1798621b 3448 cygwin32_conv_to_full_win32_path (Tcl_GetStringFromObj (objv[1], NULL), pathname);
ca4e7e14
JI		 3449 for (ptr = pathname; *ptr; ptr++)
3450 {
3451 if (*ptr == '\\')
3452 *ptr = '/';
3453 }
3454 Tcl_SetStringObj (result_ptr->obj_ptr, pathname, -1);
3455 }
3456#else
3457 Tcl_SetStringObj (result_ptr->obj_ptr, Tcl_GetStringFromObj (objv[1], NULL), -1);
3458#endif
3459
3460 return TCL_OK;
3461}
3462\f
3463/*
3464 * This section has utility routines that are not Tcl commands.
3465 */
3466
3467static int
3468perror_with_name_wrapper (args)
3469 char * args;
3470{
3471 perror_with_name (args);
3472 return 1;
3473}
3474
3475/* The lookup_symtab() in symtab.c doesn't work correctly */
3476/* It will not work will full pathnames and if multiple */
3477/* source files have the same basename, it will return */
3478/* the first one instead of the correct one. This version */
3479/* also always makes sure symtab->fullname is set. */
3480
3481static struct symtab *
3482full_lookup_symtab(file)
3483 char *file;
3484{
3485 struct symtab *st;
3486 struct objfile *objfile;
3487 char *bfile, *fullname;
3488 struct partial_symtab *pt;
3489
3490 if (!file)
3491 return NULL;
3492
3493 /* first try a direct lookup */
3494 st = lookup_symtab (file);
3495 if (st)
3496 {
3497 if (!st->fullname)
3498 symtab_to_filename(st);
3499 return st;
3500 }
3501
3502 /* if the direct approach failed, try */
3503 /* looking up the basename and checking */
3504 /* all matches with the fullname */
3505 bfile = basename (file);
3506 ALL_SYMTABS (objfile, st)
3507 {
3508 if (!strcmp (bfile, basename(st->filename)))
4af2d83a
KS		 3509 {
3510 if (!st->fullname)
3511 fullname = symtab_to_filename (st);
3512 else
3513 fullname = st->fullname;
ca4e7e14 3514
4af2d83a
KS		 3515 if (!strcmp (file, fullname))
3516 return st;
3517 }
ca4e7e14
JI		 3518 }
3519
3520 /* still no luck? look at psymtabs */
3521 ALL_PSYMTABS (objfile, pt)
3522 {
3523 if (!strcmp (bfile, basename(pt->filename)))
4af2d83a
KS		 3524 {
3525 st = PSYMTAB_TO_SYMTAB (pt);
3526 if (st)
3527 {
3528 fullname = symtab_to_filename (st);
3529 if (!strcmp (file, fullname))
3530 return st;
3531 }
3532 }
ca4e7e14
JI		 3533 }
3534 return NULL;
3535}
GDB Binutils - Deliverables
This page took 0.17882 seconds and 4 git commands to generate.