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