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