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