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