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