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