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