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