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