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