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