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