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