gdb/gdbtk.c

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