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;
1282   int files_size;
1283   int i, numfiles = 0, len = 0;
1284   Tcl_Obj *mylist;
1285
1286   files_size = 1000;
1287   files = (char **) xmalloc (sizeof (char *) * files_size);
1288
1289   if (objc > 2)
1290     {
1291       Tcl_WrongNumArgs (interp, 1, objv, "Usage: gdb_listfiles ?pathname?");
1292       return TCL_ERROR;
1293     }
1294   else if (objc == 2)
1295     pathname = Tcl_GetStringFromObj (objv[1], &len);
1296
1297   mylist = Tcl_NewListObj (0, NULL);
1298
1299   ALL_PSYMTABS (objfile, psymtab)
1300     {
1301       if (numfiles == files_size)
1302         {
1303            files_size = files_size * 2;
1304            files = (char **) xrealloc (files, sizeof (char *) * files_size);
1305         }
1306       if (len == 0)
1307         {
1308           if (psymtab->filename)
1309             files[numfiles++] = basename(psymtab->filename);
1310         }
1311       else if (!strcmp(psymtab->filename,basename(psymtab->filename))
1312                || !strncmp(pathname,psymtab->filename,len))
1313         if (psymtab->filename)
1314           files[numfiles++] = basename(psymtab->filename);
1315     }
1316
1317   ALL_SYMTABS (objfile, symtab)
1318     {
1319       if (numfiles == files_size)
1320         {
1321            files_size = files_size * 2;
1322            files = (char **) xrealloc (files, sizeof (char *) * files_size);
1323         }
1324       if (len == 0)
1325         {
1326           if (symtab->filename)
1327             files[numfiles++] = basename(symtab->filename);
1328         }
1329       else if (!strcmp(symtab->filename,basename(symtab->filename))
1330                || !strncmp(pathname,symtab->filename,len))
1331         if (symtab->filename)
1332           files[numfiles++] = basename(symtab->filename);
1333     }
1334
1335   qsort (files, numfiles, sizeof(char *), comp_files);
1336
1337   lastfile = "";
1338   for (i = 0; i < numfiles; i++)
1339     {
1340       if (strcmp(files[i],lastfile))
1341         Tcl_ListObjAppendElement (interp, mylist, Tcl_NewStringObj(files[i], -1));
1342       lastfile = files[i];
1343     }
1344   Tcl_SetObjResult (interp, mylist);
1345   free (files);
1346   return TCL_OK;
1347 }
1348
1349 static int
1350 gdb_listfuncs (clientData, interp, argc, argv)
1351      ClientData clientData;
1352      Tcl_Interp *interp;
1353      int argc;
1354      char *argv[];
1355 {
1356   struct symtab *symtab;
1357   struct blockvector *bv;
1358   struct block *b;
1359   struct symbol *sym;
1360   char buf[128];
1361   int i,j;
1362
1363   if (argc != 2)
1364     error ("wrong # args");
1365
1366   symtab = full_lookup_symtab (argv[1]);
1367   if (!symtab)
1368     error ("No such file");
1369
1370   bv = BLOCKVECTOR (symtab);
1371   for (i = GLOBAL_BLOCK; i <= STATIC_BLOCK; i++)
1372     {
1373       b = BLOCKVECTOR_BLOCK (bv, i);
1374       /* Skip the sort if this block is always sorted.  */
1375       if (!BLOCK_SHOULD_SORT (b))
1376         sort_block_syms (b);
1377       for (j = 0; j < BLOCK_NSYMS (b); j++)
1378         {
1379           sym = BLOCK_SYM (b, j);
1380           if (SYMBOL_CLASS (sym) == LOC_BLOCK)
1381             {
1382
1383               char *name = cplus_demangle (SYMBOL_NAME(sym), 0);
1384               if (name)
1385                 {
1386                   sprintf (buf,"{%s} 1", name);
1387                 }
1388               else
1389                 sprintf (buf,"{%s} 0", SYMBOL_NAME(sym));
1390               Tcl_DStringAppendElement (result_ptr, buf);
1391             }
1392         }
1393     }
1394   return TCL_OK;
1395 }
1396
1397 static int
1398 target_stop_wrapper (args)
1399   char * args;
1400 {
1401   target_stop ();
1402   return 1;
1403 }
1404
1405 static int
1406 gdb_stop (clientData, interp, argc, argv)
1407      ClientData clientData;
1408      Tcl_Interp *interp;
1409      int argc;
1410      char *argv[];
1411 {
1412   if (target_stop)
1413     {
1414       catch_errors (target_stop_wrapper, NULL, "",
1415                     RETURN_MASK_ALL);
1416     }
1417   else
1418     quit_flag = 1; /* hope something sees this */
1419
1420   return TCL_OK;
1421 }
1422
1423 /* Prepare to accept a new executable file.  This is called when we
1424    want to clear away everything we know about the old file, without
1425    asking the user.  The Tcl code will have already asked the user if
1426    necessary.  After this is called, we should be able to run the
1427    `file' command without getting any questions.  */
1428
1429 static int
1430 gdb_clear_file (clientData, interp, argc, argv)
1431      ClientData clientData;
1432      Tcl_Interp *interp;
1433      int argc;
1434      char *argv[];
1435 {
1436   if (inferior_pid != 0 && target_has_execution)
1437     {
1438       if (attach_flag)
1439         target_detach (NULL, 0);
1440       else
1441         target_kill ();
1442     }
1443
1444   if (target_has_execution)
1445     pop_target ();
1446
1447   symbol_file_command (NULL, 0);
1448
1449   /* gdb_loc refers to stop_pc, but nothing seems to clear it, so we
1450      clear it here.  FIXME: This seems like an abstraction violation
1451      somewhere.  */
1452   stop_pc = 0;
1453
1454   return TCL_OK;
1455 }
1456
1457 /* Ask the user to confirm an exit request.  */
1458
1459 static int
1460 gdb_confirm_quit (clientData, interp, argc, argv)
1461      ClientData clientData;
1462      Tcl_Interp *interp;
1463      int argc;
1464      char *argv[];
1465 {
1466   int ret;
1467
1468   ret = quit_confirm ();
1469   Tcl_DStringAppendElement (result_ptr, ret ? "1" : "0");
1470   return TCL_OK;
1471 }
1472
1473 /* Quit without asking for confirmation.  */
1474
1475 static int
1476 gdb_force_quit (clientData, interp, argc, argv)
1477      ClientData clientData;
1478      Tcl_Interp *interp;
1479      int argc;
1480      char *argv[];
1481 {
1482   quit_force ((char *) NULL, 1);
1483   return TCL_OK;
1484 }
1485 \f
1486 /* This implements the TCL command `gdb_disassemble'.  */
1487
1488 static int
1489 gdbtk_dis_asm_read_memory (memaddr, myaddr, len, info)
1490      bfd_vma memaddr;
1491      bfd_byte *myaddr;
1492      int len;
1493      disassemble_info *info;
1494 {
1495   extern struct target_ops exec_ops;
1496   int res;
1497
1498   errno = 0;
1499   res = xfer_memory (memaddr, myaddr, len, 0, &exec_ops);
1500
1501   if (res == len)
1502     return 0;
1503   else
1504     if (errno == 0)
1505       return EIO;
1506     else
1507       return errno;
1508 }
1509
1510 /* We need a different sort of line table from the normal one cuz we can't
1511    depend upon implicit line-end pc's for lines.  This is because of the
1512    reordering we are about to do.  */
1513
1514 struct my_line_entry {
1515   int line;
1516   CORE_ADDR start_pc;
1517   CORE_ADDR end_pc;
1518 };
1519
1520 static int
1521 compare_lines (mle1p, mle2p)
1522      const PTR mle1p;
1523      const PTR mle2p;
1524 {
1525   struct my_line_entry *mle1, *mle2;
1526   int val;
1527
1528   mle1 = (struct my_line_entry *) mle1p;
1529   mle2 = (struct my_line_entry *) mle2p;
1530
1531   val =  mle1->line - mle2->line;
1532
1533   if (val != 0)
1534     return val;
1535
1536   return mle1->start_pc - mle2->start_pc;
1537 }
1538
1539 static int
1540 gdb_disassemble (clientData, interp, argc, argv)
1541      ClientData clientData;
1542      Tcl_Interp *interp;
1543      int argc;
1544      char *argv[];
1545 {
1546   CORE_ADDR pc, low, high;
1547   int mixed_source_and_assembly;
1548   static disassemble_info di;
1549   static int di_initialized;
1550
1551   if (! di_initialized)
1552     {
1553       INIT_DISASSEMBLE_INFO_NO_ARCH (di, gdb_stdout,
1554                                      (fprintf_ftype) fprintf_unfiltered);
1555       di.flavour = bfd_target_unknown_flavour;
1556       di.memory_error_func = dis_asm_memory_error;
1557       di.print_address_func = dis_asm_print_address;
1558       di_initialized = 1;
1559     }
1560
1561   di.mach = tm_print_insn_info.mach;
1562   if (TARGET_BYTE_ORDER == BIG_ENDIAN)
1563     di.endian = BFD_ENDIAN_BIG;
1564   else
1565     di.endian = BFD_ENDIAN_LITTLE;
1566
1567   if (argc != 3 && argc != 4)
1568     error ("wrong # args");
1569
1570   if (strcmp (argv[1], "source") == 0)
1571     mixed_source_and_assembly = 1;
1572   else if (strcmp (argv[1], "nosource") == 0)
1573     mixed_source_and_assembly = 0;
1574   else
1575     error ("First arg must be 'source' or 'nosource'");
1576
1577   low = parse_and_eval_address (argv[2]);
1578
1579   if (argc == 3)
1580     {
1581       if (find_pc_partial_function (low, NULL, &low, &high) == 0)
1582         error ("No function contains specified address");
1583     }
1584   else
1585     high = parse_and_eval_address (argv[3]);
1586
1587   /* If disassemble_from_exec == -1, then we use the following heuristic to
1588      determine whether or not to do disassembly from target memory or from the
1589      exec file:
1590
1591      If we're debugging a local process, read target memory, instead of the
1592      exec file.  This makes disassembly of functions in shared libs work
1593      correctly.
1594
1595      Else, we're debugging a remote process, and should disassemble from the
1596      exec file for speed.  However, this is no good if the target modifies its
1597      code (for relocation, or whatever).
1598    */
1599
1600   if (disassemble_from_exec == -1)
1601     if (strcmp (target_shortname, "child") == 0
1602         || strcmp (target_shortname, "procfs") == 0
1603         || strcmp (target_shortname, "vxprocess") == 0)
1604       disassemble_from_exec = 0; /* It's a child process, read inferior mem */
1605     else
1606       disassemble_from_exec = 1; /* It's remote, read the exec file */
1607
1608   if (disassemble_from_exec)
1609     di.read_memory_func = gdbtk_dis_asm_read_memory;
1610   else
1611     di.read_memory_func = dis_asm_read_memory;
1612
1613   /* If just doing straight assembly, all we need to do is disassemble
1614      everything between low and high.  If doing mixed source/assembly, we've
1615      got a totally different path to follow.  */
1616
1617   if (mixed_source_and_assembly)
1618     {                           /* Come here for mixed source/assembly */
1619       /* The idea here is to present a source-O-centric view of a function to
1620          the user.  This means that things are presented in source order, with
1621          (possibly) out of order assembly immediately following.  */
1622       struct symtab *symtab;
1623       struct linetable_entry *le;
1624       int nlines;
1625       int newlines;
1626       struct my_line_entry *mle;
1627       struct symtab_and_line sal;
1628       int i;
1629       int out_of_order;
1630       int next_line;
1631
1632       symtab = find_pc_symtab (low); /* Assume symtab is valid for whole PC range */
1633
1634       if (!symtab)
1635         goto assembly_only;
1636
1637 /* First, convert the linetable to a bunch of my_line_entry's.  */
1638
1639       le = symtab->linetable->item;
1640       nlines = symtab->linetable->nitems;
1641
1642       if (nlines <= 0)
1643         goto assembly_only;
1644
1645       mle = (struct my_line_entry *) alloca (nlines * sizeof (struct my_line_entry));
1646
1647       out_of_order = 0;
1648
1649 /* Copy linetable entries for this function into our data structure, creating
1650    end_pc's and setting out_of_order as appropriate.  */
1651
1652 /* First, skip all the preceding functions.  */
1653
1654       for (i = 0; i < nlines - 1 && le[i].pc < low; i++) ;
1655
1656 /* Now, copy all entries before the end of this function.  */
1657
1658       newlines = 0;
1659       for (; i < nlines - 1 && le[i].pc < high; i++)
1660         {
1661           if (le[i].line == le[i + 1].line
1662               && le[i].pc == le[i + 1].pc)
1663             continue;           /* Ignore duplicates */
1664
1665           mle[newlines].line = le[i].line;
1666           if (le[i].line > le[i + 1].line)
1667             out_of_order = 1;
1668           mle[newlines].start_pc = le[i].pc;
1669           mle[newlines].end_pc = le[i + 1].pc;
1670           newlines++;
1671         }
1672
1673 /* If we're on the last line, and it's part of the function, then we need to
1674    get the end pc in a special way.  */
1675
1676       if (i == nlines - 1
1677           && le[i].pc < high)
1678         {
1679           mle[newlines].line = le[i].line;
1680           mle[newlines].start_pc = le[i].pc;
1681           sal = find_pc_line (le[i].pc, 0);
1682           mle[newlines].end_pc = sal.end;
1683           newlines++;
1684         }
1685
1686 /* Now, sort mle by line #s (and, then by addresses within lines). */
1687
1688       if (out_of_order)
1689         qsort (mle, newlines, sizeof (struct my_line_entry), compare_lines);
1690
1691 /* Now, for each line entry, emit the specified lines (unless they have been
1692    emitted before), followed by the assembly code for that line.  */
1693
1694       next_line = 0;            /* Force out first line */
1695       for (i = 0; i < newlines; i++)
1696         {
1697 /* Print out everything from next_line to the current line.  */
1698
1699           if (mle[i].line >= next_line)
1700             {
1701               if (next_line != 0)
1702                 print_source_lines (symtab, next_line, mle[i].line + 1, 0);
1703               else
1704                 print_source_lines (symtab, mle[i].line, mle[i].line + 1, 0);
1705
1706               next_line = mle[i].line + 1;
1707             }
1708
1709           for (pc = mle[i].start_pc; pc < mle[i].end_pc; )
1710             {
1711               QUIT;
1712               fputs_unfiltered ("    ", gdb_stdout);
1713               print_address (pc, gdb_stdout);
1714               fputs_unfiltered (":\t    ", gdb_stdout);
1715               pc += (*tm_print_insn) (pc, &di);
1716               fputs_unfiltered ("\n", gdb_stdout);
1717             }
1718         }
1719     }
1720   else
1721     {
1722 assembly_only:
1723       for (pc = low; pc < high; )
1724         {
1725           QUIT;
1726           fputs_unfiltered ("    ", gdb_stdout);
1727           print_address (pc, gdb_stdout);
1728           fputs_unfiltered (":\t    ", gdb_stdout);
1729           pc += (*tm_print_insn) (pc, &di);
1730           fputs_unfiltered ("\n", gdb_stdout);
1731         }
1732     }
1733
1734   gdb_flush (gdb_stdout);
1735
1736   return TCL_OK;
1737 }
1738 \f
1739 static void
1740 tk_command (cmd, from_tty)
1741      char *cmd;
1742      int from_tty;
1743 {
1744   int retval;
1745   char *result;
1746   struct cleanup *old_chain;
1747
1748   /* Catch case of no argument, since this will make the tcl interpreter dump core. */
1749   if (cmd == NULL)
1750     error_no_arg ("tcl command to interpret");
1751
1752   retval = Tcl_Eval (interp, cmd);
1753
1754   result = strdup (interp->result);
1755
1756   old_chain = make_cleanup (free, result);
1757
1758   if (retval != TCL_OK)
1759     error (result);
1760
1761   printf_unfiltered ("%s\n", result);
1762
1763   do_cleanups (old_chain);
1764 }
1765
1766 static void
1767 cleanup_init (ignored)
1768      int ignored;
1769 {
1770   if (interp != NULL)
1771     Tcl_DeleteInterp (interp);
1772   interp = NULL;
1773 }
1774
1775 /* Come here during long calculations to check for GUI events.  Usually invoked
1776    via the QUIT macro.  */
1777
1778 static void
1779 gdbtk_interactive ()
1780 {
1781   /* Tk_DoOneEvent (TK_DONT_WAIT|TK_IDLE_EVENTS); */
1782 }
1783
1784 /* Come here when there is activity on the X file descriptor. */
1785
1786 static void
1787 x_event (signo)
1788      int signo;
1789 {
1790   static int in_x_event = 0;
1791   static Tcl_Obj *varname = NULL;
1792
1793   if (in_x_event || in_fputs)
1794     return;
1795
1796   in_x_event = 1;
1797
1798   /* Process pending events */
1799   while (Tcl_DoOneEvent (TCL_DONT_WAIT|TCL_ALL_EVENTS) != 0)
1800     ;
1801
1802   if (load_in_progress)
1803     {
1804       int val;
1805       if (varname == NULL)
1806         {
1807           Tcl_Obj *varnamestrobj = Tcl_NewStringObj("download_cancel_ok",-1);
1808           varname = Tcl_ObjGetVar2(interp,varnamestrobj,NULL,TCL_GLOBAL_ONLY);
1809         }
1810       if ((Tcl_GetIntFromObj(interp,varname,&val) == TCL_OK) && val)
1811         {
1812           quit_flag = 1;
1813 #ifdef REQUEST_QUIT
1814           REQUEST_QUIT;
1815 #else
1816           if (immediate_quit)
1817             quit ();
1818 #endif
1819         }
1820     }
1821   in_x_event = 0;
1822 }
1823
1824 #ifdef __CYGWIN32__
1825
1826 /* For Cygwin32, we use a timer to periodically check for Windows
1827    messages.  FIXME: It would be better to not poll, but to instead
1828    rewrite the target_wait routines to serve as input sources.
1829    Unfortunately, that will be a lot of work.  */
1830 static sigset_t nullsigmask;
1831 static struct sigaction act1, act2;
1832 static struct itimerval it_on, it_off;
1833
1834 static void
1835 gdbtk_start_timer ()
1836 {
1837   static int first = 1;
1838   /*TclDebug ("Starting timer....");*/
1839   if (first)
1840     {
1841       /* first time called, set up all the structs */
1842       first = 0;
1843       sigemptyset (&nullsigmask);
1844
1845       act1.sa_handler = x_event;
1846       act1.sa_mask = nullsigmask;
1847       act1.sa_flags = 0;
1848
1849       act2.sa_handler = SIG_IGN;
1850       act2.sa_mask = nullsigmask;
1851       act2.sa_flags = 0;
1852
1853       it_on.it_interval.tv_sec = 0;
1854       it_on.it_interval.tv_usec = 500000; /* .5 sec */
1855       it_on.it_value.tv_sec = 0;
1856       it_on.it_value.tv_usec = 500000;
1857
1858       it_off.it_interval.tv_sec = 0;
1859       it_off.it_interval.tv_usec = 0;
1860       it_off.it_value.tv_sec = 0;
1861       it_off.it_value.tv_usec = 0;
1862     }
1863   sigaction (SIGALRM, &act1, NULL);
1864   setitimer (ITIMER_REAL, &it_on, NULL);
1865   gdbtk_timer_going = 1;
1866 }
1867
1868 static void
1869 gdbtk_stop_timer ()
1870 {
1871   gdbtk_timer_going = 0;
1872   /*TclDebug ("Stopping timer.");*/
1873   setitimer (ITIMER_REAL, &it_off, NULL);
1874   sigaction (SIGALRM, &act2, NULL);
1875 }
1876
1877 #endif
1878
1879 /* This hook function is called whenever we want to wait for the
1880    target.  */
1881
1882 static int
1883 gdbtk_wait (pid, ourstatus)
1884      int pid;
1885      struct target_waitstatus *ourstatus;
1886 {
1887 #ifndef WINNT
1888   struct sigaction action;
1889   static sigset_t nullsigmask = {0};
1890
1891
1892 #ifndef SA_RESTART
1893   /* Needed for SunOS 4.1.x */
1894 #define SA_RESTART 0
1895 #endif
1896
1897   action.sa_handler = x_event;
1898   action.sa_mask = nullsigmask;
1899   action.sa_flags = SA_RESTART;
1900   sigaction(SIGIO, &action, NULL);
1901 #endif /* WINNT */
1902
1903   pid = target_wait (pid, ourstatus);
1904
1905 #ifndef WINNT
1906   action.sa_handler = SIG_IGN;
1907   sigaction(SIGIO, &action, NULL);
1908 #endif
1909
1910   return pid;
1911 }
1912
1913 /* This is called from execute_command, and provides a wrapper around
1914    various command routines in a place where both protocol messages and
1915    user input both flow through.  Mostly this is used for indicating whether
1916    the target process is running or not.
1917 */
1918
1919 static void
1920 gdbtk_call_command (cmdblk, arg, from_tty)
1921      struct cmd_list_element *cmdblk;
1922      char *arg;
1923      int from_tty;
1924 {
1925   running_now = 0;
1926   if (cmdblk->class == class_run || cmdblk->class == class_trace)
1927     {
1928       running_now = 1;
1929       if (!No_Update)
1930         Tcl_Eval (interp, "gdbtk_tcl_busy");
1931       (*cmdblk->function.cfunc)(arg, from_tty);
1932       running_now = 0;
1933       if (!No_Update)
1934         Tcl_Eval (interp, "gdbtk_tcl_idle");
1935     }
1936   else
1937     (*cmdblk->function.cfunc)(arg, from_tty);
1938 }
1939
1940 /* This function is called instead of gdb's internal command loop.  This is the
1941    last chance to do anything before entering the main Tk event loop. */
1942
1943 static void
1944 tk_command_loop ()
1945 {
1946   extern GDB_FILE *instream;
1947
1948   /* We no longer want to use stdin as the command input stream */
1949   instream = NULL;
1950
1951   if (Tcl_Eval (interp, "gdbtk_tcl_preloop") != TCL_OK)
1952     {
1953       char *msg;
1954
1955       /* Force errorInfo to be set up propertly.  */
1956       Tcl_AddErrorInfo (interp, "");
1957
1958       msg = Tcl_GetVar (interp, "errorInfo", TCL_GLOBAL_ONLY);
1959 #ifdef _WIN32
1960       MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL);
1961 #else
1962       fputs_unfiltered (msg, gdb_stderr);
1963 #endif
1964     }
1965
1966 #ifdef _WIN32
1967   close_bfds ();
1968 #endif
1969
1970   Tk_MainLoop ();
1971 }
1972
1973 /* gdbtk_init installs this function as a final cleanup.  */
1974
1975 static void
1976 gdbtk_cleanup (dummy)
1977      PTR dummy;
1978 {
1979 #ifdef IDE
1980   struct ide_event_handle *h = (struct ide_event_handle *) dummy;
1981
1982   ide_interface_deregister_all (h);
1983 #endif
1984   Tcl_Finalize ();
1985 }
1986
1987 /* Initialize gdbtk.  */
1988
1989 static void
1990 gdbtk_init ( argv0 )
1991      char *argv0;
1992 {
1993   struct cleanup *old_chain;
1994   char *lib, *gdbtk_lib, *gdbtk_lib_tmp, *gdbtk_file;
1995   int i, found_main;
1996 #ifndef WINNT
1997   struct sigaction action;
1998   static sigset_t nullsigmask = {0};
1999 #endif
2000 #ifdef IDE
2001   /* start-sanitize-ide */
2002   struct ide_event_handle *h;
2003   const char *errmsg;
2004   char *libexecdir;
2005   /* end-sanitize-ide */
2006 #endif
2007
2008   /* If there is no DISPLAY environment variable, Tk_Init below will fail,
2009      causing gdb to abort.  If instead we simply return here, gdb will
2010      gracefully degrade to using the command line interface. */
2011
2012 #ifndef WINNT
2013   if (getenv ("DISPLAY") == NULL)
2014     return;
2015 #endif
2016
2017   old_chain = make_cleanup (cleanup_init, 0);
2018
2019   /* First init tcl and tk. */
2020   Tcl_FindExecutable (argv0);
2021   interp = Tcl_CreateInterp ();
2022
2023 #ifdef TCL_MEM_DEBUG
2024   Tcl_InitMemory (interp);
2025 #endif
2026
2027   if (!interp)
2028     error ("Tcl_CreateInterp failed");
2029
2030   if (Tcl_Init(interp) != TCL_OK)
2031     error ("Tcl_Init failed: %s", interp->result);
2032
2033 #ifndef IDE
2034   /* For the IDE we register the cleanup later, after we've
2035      initialized events.  */
2036   make_final_cleanup (gdbtk_cleanup,  NULL);
2037 #endif
2038
2039   /* Initialize the Paths variable.  */
2040   if (ide_initialize_paths (interp, "gdbtcl") != TCL_OK)
2041     error ("ide_initialize_paths failed: %s", interp->result);
2042
2043 #ifdef IDE
2044   /* start-sanitize-ide */
2045   /* Find the directory where we expect to find idemanager.  We ignore
2046      errors since it doesn't really matter if this fails.  */
2047   libexecdir = Tcl_GetVar2 (interp, "Paths", "libexecdir", TCL_GLOBAL_ONLY);
2048
2049   IluTk_Init ();
2050
2051   h = ide_event_init_from_environment (&errmsg, libexecdir);
2052   make_final_cleanup (gdbtk_cleanup, h);
2053   if (h == NULL)
2054     {
2055       Tcl_AppendResult (interp, "can't initialize event system: ", errmsg,
2056                         (char *) NULL);
2057       fprintf(stderr, "WARNING: ide_event_init_client failed: %s\n", interp->result);
2058
2059       Tcl_SetVar (interp, "GDBTK_IDE", "0", 0);
2060     }
2061   else
2062     {
2063       if (ide_create_tclevent_command (interp, h) != TCL_OK)
2064         error ("ide_create_tclevent_command failed: %s", interp->result);
2065
2066       if (ide_create_edit_command (interp, h) != TCL_OK)
2067         error ("ide_create_edit_command failed: %s", interp->result);
2068
2069       if (ide_create_property_command (interp, h) != TCL_OK)
2070         error ("ide_create_property_command failed: %s", interp->result);
2071
2072       if (ide_create_build_command (interp, h) != TCL_OK)
2073         error ("ide_create_build_command failed: %s", interp->result);
2074
2075       if (ide_create_window_register_command (interp, h, "gdb-restore")
2076           != TCL_OK)
2077         error ("ide_create_window_register_command failed: %s",
2078                interp->result);
2079
2080       if (ide_create_window_command (interp, h) != TCL_OK)
2081         error ("ide_create_window_command failed: %s", interp->result);
2082
2083       if (ide_create_exit_command (interp, h) != TCL_OK)
2084         error ("ide_create_exit_command failed: %s", interp->result);
2085
2086       if (ide_create_help_command (interp) != TCL_OK)
2087         error ("ide_create_help_command failed: %s", interp->result);
2088
2089       /*
2090         if (ide_initialize (interp, "gdb") != TCL_OK)
2091         error ("ide_initialize failed: %s", interp->result);
2092       */
2093
2094       Tcl_SetVar (interp, "GDBTK_IDE", "1", 0);
2095     }
2096   /* end-sanitize-ide */
2097 #else
2098   Tcl_SetVar (interp, "GDBTK_IDE", "0", 0);
2099 #endif /* IDE */
2100
2101   /* We don't want to open the X connection until we've done all the
2102      IDE initialization.  Otherwise, goofy looking unfinished windows
2103      pop up when ILU drops into the TCL event loop.  */
2104
2105   if (Tk_Init(interp) != TCL_OK)
2106     error ("Tk_Init failed: %s", interp->result);
2107
2108   if (Itcl_Init(interp) == TCL_ERROR)
2109     error ("Itcl_Init failed: %s", interp->result);
2110
2111   if (Tix_Init(interp) != TCL_OK)
2112     error ("Tix_Init failed: %s", interp->result);
2113
2114 #ifdef __CYGWIN32__
2115   if (ide_create_messagebox_command (interp) != TCL_OK)
2116     error ("messagebox command initialization failed");
2117   /* On Windows, create a sizebox widget command */
2118   if (ide_create_sizebox_command (interp) != TCL_OK)
2119     error ("sizebox creation failed");
2120   if (ide_create_winprint_command (interp) != TCL_OK)
2121     error ("windows print code initialization failed");
2122   /* start-sanitize-ide */
2123   /* An interface to ShellExecute.  */
2124   if (ide_create_shell_execute_command (interp) != TCL_OK)
2125     error ("shell execute command initialization failed");
2126   /* end-sanitize-ide */
2127   if (ide_create_win_grab_command (interp) != TCL_OK)
2128     error ("grab support command initialization failed");
2129   /* Path conversion functions.  */
2130   if (ide_create_cygwin_path_command (interp) != TCL_OK)
2131     error ("cygwin path command initialization failed");
2132 #endif
2133
2134   Tcl_CreateCommand (interp, "gdb_cmd", call_wrapper, gdb_cmd, NULL);
2135   Tcl_CreateCommand (interp, "gdb_immediate", call_wrapper,
2136                      gdb_immediate_command, NULL);
2137   Tcl_CreateCommand (interp, "gdb_loc", call_wrapper, gdb_loc, NULL);
2138   Tcl_CreateCommand (interp, "gdb_path_conv", call_wrapper, gdb_path_conv, NULL);
2139   Tcl_CreateObjCommand (interp, "gdb_listfiles", gdb_listfiles, NULL, NULL);
2140   Tcl_CreateCommand (interp, "gdb_listfuncs", call_wrapper, gdb_listfuncs,
2141                      NULL);
2142   Tcl_CreateCommand (interp, "gdb_get_mem", call_wrapper, gdb_get_mem,
2143                      NULL);
2144   Tcl_CreateCommand (interp, "gdb_stop", call_wrapper, gdb_stop, NULL);
2145   Tcl_CreateCommand (interp, "gdb_regnames", call_wrapper, gdb_regnames, NULL);
2146   Tcl_CreateCommand (interp, "gdb_fetch_registers", call_wrapper,
2147                      gdb_fetch_registers, NULL);
2148   Tcl_CreateCommand (interp, "gdb_changed_register_list", call_wrapper,
2149                      gdb_changed_register_list, NULL);
2150   Tcl_CreateCommand (interp, "gdb_disassemble", call_wrapper,
2151                      gdb_disassemble, NULL);
2152   Tcl_CreateCommand (interp, "gdb_eval", call_wrapper, gdb_eval, NULL);
2153   Tcl_CreateCommand (interp, "gdb_get_breakpoint_list", call_wrapper,
2154                      gdb_get_breakpoint_list, NULL);
2155   Tcl_CreateCommand (interp, "gdb_get_breakpoint_info", call_wrapper,
2156                      gdb_get_breakpoint_info, NULL);
2157   Tcl_CreateCommand (interp, "gdb_clear_file", call_wrapper,
2158                      gdb_clear_file, NULL);
2159   Tcl_CreateCommand (interp, "gdb_confirm_quit", call_wrapper,
2160                      gdb_confirm_quit, NULL);
2161   Tcl_CreateCommand (interp, "gdb_force_quit", call_wrapper,
2162                      gdb_force_quit, NULL);
2163   Tcl_CreateCommand (interp, "gdb_target_has_execution",
2164                      gdb_target_has_execution_command,
2165                      NULL, NULL);
2166   Tcl_CreateCommand (interp, "gdb_is_tracing",
2167                      gdb_trace_status,
2168                      NULL, NULL);
2169   Tcl_CreateObjCommand (interp, "gdb_load_info", gdb_load_info, NULL, NULL);
2170   Tcl_CreateObjCommand (interp, "gdb_get_locals", gdb_get_vars_command,
2171                         (ClientData) 0, NULL);
2172   Tcl_CreateObjCommand (interp, "gdb_get_args", gdb_get_vars_command,
2173                         (ClientData) 1, NULL);
2174   Tcl_CreateObjCommand (interp, "gdb_get_function", gdb_get_function_command,
2175                         NULL, NULL);
2176   Tcl_CreateObjCommand (interp, "gdb_get_line", gdb_get_line_command,
2177                         NULL, NULL);
2178   Tcl_CreateObjCommand (interp, "gdb_get_file", gdb_get_file_command,
2179                         NULL, NULL);
2180   Tcl_CreateObjCommand (interp, "gdb_tracepoint_exists",
2181                         gdb_tracepoint_exists_command, NULL, NULL);
2182   Tcl_CreateObjCommand (interp, "gdb_get_tracepoint_info",
2183                         gdb_get_tracepoint_info, NULL, NULL);
2184   Tcl_CreateObjCommand (interp, "gdb_actions",
2185                         gdb_actions_command, NULL, NULL);
2186   Tcl_CreateObjCommand (interp, "gdb_prompt",
2187                         gdb_prompt_command, NULL, NULL);
2188   Tcl_CreateObjCommand (interp, "gdb_find_file",
2189                         gdb_find_file_command, NULL, NULL);
2190   Tcl_CreateObjCommand (interp, "gdb_get_tracepoint_list",
2191                         gdb_get_tracepoint_list, NULL, NULL);
2192   Tcl_CreateCommand (interp, "gdb_pc_reg", get_pc_register, NULL, NULL);
2193   Tcl_CreateObjCommand (interp, "gdb_loadfile", gdb_loadfile, NULL, NULL);
2194   Tcl_CreateObjCommand (interp, "gdb_set_bp", gdb_set_bp, NULL, NULL);
2195
2196   command_loop_hook = tk_command_loop;
2197   print_frame_info_listing_hook = gdbtk_print_frame_info;
2198   query_hook = gdbtk_query;
2199   flush_hook = gdbtk_flush;
2200   create_breakpoint_hook = gdbtk_create_breakpoint;
2201   delete_breakpoint_hook = gdbtk_delete_breakpoint;
2202   modify_breakpoint_hook = gdbtk_modify_breakpoint;
2203   interactive_hook = gdbtk_interactive;
2204   target_wait_hook = gdbtk_wait;
2205   call_command_hook = gdbtk_call_command;
2206   readline_begin_hook = gdbtk_readline_begin;
2207   readline_hook = gdbtk_readline;
2208   readline_end_hook = gdbtk_readline_end;
2209   ui_load_progress_hook = gdbtk_load_hash;
2210   pre_add_symbol_hook   = gdbtk_pre_add_symbol;
2211   post_add_symbol_hook  = gdbtk_post_add_symbol;
2212   create_tracepoint_hook = gdbtk_create_tracepoint;
2213   delete_tracepoint_hook = gdbtk_delete_tracepoint;
2214   modify_tracepoint_hook = gdbtk_modify_tracepoint;
2215   pc_changed_hook = pc_changed;
2216 #ifdef __CYGWIN32__
2217   annotate_starting_hook  = gdbtk_annotate_starting;
2218   annotate_stopped_hook   = gdbtk_annotate_stopped;
2219   annotate_signalled_hook = gdbtk_annotate_signalled;
2220   annotate_exited_hook    = gdbtk_annotate_exited;
2221   ui_loop_hook            = x_event;
2222 #endif
2223 #ifndef WINNT
2224   /* Get the file descriptor for the X server */
2225
2226   x_fd = ConnectionNumber (Tk_Display (Tk_MainWindow (interp)));
2227
2228   /* Setup for I/O interrupts */
2229
2230   action.sa_mask = nullsigmask;
2231   action.sa_flags = 0;
2232   action.sa_handler = SIG_IGN;
2233   sigaction(SIGIO, &action, NULL);
2234
2235 #ifdef FIOASYNC
2236   i = 1;
2237   if (ioctl (x_fd, FIOASYNC, &i))
2238     perror_with_name ("gdbtk_init: ioctl FIOASYNC failed");
2239
2240 #ifdef SIOCSPGRP
2241   i = getpid();
2242   if (ioctl (x_fd, SIOCSPGRP, &i))
2243     perror_with_name ("gdbtk_init: ioctl SIOCSPGRP failed");
2244
2245 #else
2246 #ifdef F_SETOWN
2247   i = getpid();
2248   if (fcntl (x_fd, F_SETOWN, i))
2249     perror_with_name ("gdbtk_init: fcntl F_SETOWN failed");
2250 #endif  /* F_SETOWN */
2251 #endif  /* !SIOCSPGRP */
2252 #else
2253 #ifndef WINNT
2254   if (ioctl (x_fd,  I_SETSIG, S_INPUT|S_RDNORM) < 0)
2255     perror_with_name ("gdbtk_init: ioctl I_SETSIG failed");
2256 #endif
2257
2258 #endif /* ifndef FIOASYNC */
2259 #endif /* WINNT */
2260
2261   add_com ("tk", class_obscure, tk_command,
2262            "Send a command directly into tk.");
2263
2264   Tcl_LinkVar (interp, "disassemble-from-exec", (char *)&disassemble_from_exec,
2265                TCL_LINK_INT);
2266
2267   /* find the gdb tcl library and source main.tcl */
2268
2269   gdbtk_lib = getenv ("GDBTK_LIBRARY");
2270   if (!gdbtk_lib)
2271     if (access ("gdbtcl/main.tcl", R_OK) == 0)
2272       gdbtk_lib = "gdbtcl";
2273     else
2274       gdbtk_lib = GDBTK_LIBRARY;
2275
2276   gdbtk_lib_tmp = xstrdup (gdbtk_lib);
2277
2278   found_main = 0;
2279   /* see if GDBTK_LIBRARY is a path list */
2280   lib = strtok (gdbtk_lib_tmp, GDBTK_PATH_SEP);
2281   do
2282     {
2283       if (Tcl_VarEval (interp, "lappend auto_path ", lib, NULL) != TCL_OK)
2284         {
2285           fputs_unfiltered (Tcl_GetVar (interp, "errorInfo", 0), gdb_stderr);
2286           error ("");
2287         }
2288       if (!found_main)
2289         {
2290           gdbtk_file = concat (lib, "/main.tcl", (char *) NULL);
2291           if (access (gdbtk_file, R_OK) == 0)
2292             {
2293               found_main++;
2294               Tcl_SetVar (interp, "GDBTK_LIBRARY", lib, 0);
2295             }
2296         }
2297      }
2298   while ((lib = strtok (NULL, ":")) != NULL);
2299
2300   free (gdbtk_lib_tmp);
2301
2302   if (!found_main)
2303     {
2304       /* Try finding it with the auto path.  */
2305
2306       static const char script[] ="\
2307 proc gdbtk_find_main {} {\n\
2308   global auto_path GDBTK_LIBRARY\n\
2309   foreach dir $auto_path {\n\
2310     set f [file join $dir main.tcl]\n\
2311     if {[file exists $f]} then {\n\
2312       set GDBTK_LIBRARY $dir\n\
2313       return $f\n\
2314     }\n\
2315   }\n\
2316   return ""\n\
2317 }\n\
2318 gdbtk_find_main";
2319
2320       if (Tcl_GlobalEval (interp, (char *) script) != TCL_OK)
2321         {
2322           fputs_unfiltered (Tcl_GetVar (interp, "errorInfo", 0), gdb_stderr);
2323           error ("");
2324         }
2325
2326       if (interp->result[0] != '\0')
2327         {
2328           gdbtk_file = xstrdup (interp->result);
2329           found_main++;
2330         }
2331     }
2332
2333   if (!found_main)
2334     {
2335       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
2336       if (getenv("GDBTK_LIBRARY"))
2337         {
2338           fprintf_unfiltered (stderr, "Unable to find main.tcl in %s\n",getenv("GDBTK_LIBRARY"));
2339           fprintf_unfiltered (stderr,
2340                               "Please set GDBTK_LIBRARY to a path that includes the GDB tcl files.\n");
2341         }
2342       else
2343         {
2344           fprintf_unfiltered (stderr, "Unable to find main.tcl in %s\n", GDBTK_LIBRARY);
2345           fprintf_unfiltered (stderr, "You might want to set GDBTK_LIBRARY\n");
2346         }
2347       error("");
2348     }
2349
2350 /* Defer setup of fputs_unfiltered_hook to near the end so that error messages
2351    prior to this point go to stdout/stderr.  */
2352
2353   fputs_unfiltered_hook = gdbtk_fputs;
2354
2355   if (Tcl_EvalFile (interp, gdbtk_file) != TCL_OK)
2356     {
2357       char *msg;
2358
2359       /* Force errorInfo to be set up propertly.  */
2360       Tcl_AddErrorInfo (interp, "");
2361
2362       msg = Tcl_GetVar (interp, "errorInfo", TCL_GLOBAL_ONLY);
2363
2364       fputs_unfiltered_hook = NULL; /* Force errors to stdout/stderr */
2365
2366 #ifdef _WIN32
2367       MessageBox (NULL, msg, NULL, MB_OK | MB_ICONERROR | MB_TASKMODAL);
2368 #else
2369       fputs_unfiltered (msg, gdb_stderr);
2370 #endif
2371
2372       error ("");
2373     }
2374
2375 #ifdef IDE
2376   /* start-sanitize-ide */
2377   /* Don't do this until we have initialized.  Otherwise, we may get a
2378      run command before we are ready for one.  */
2379   if (ide_run_server_init (interp, h) != TCL_OK)
2380     error ("ide_run_server_init failed: %s", interp->result);
2381   /* end-sanitize-ide */
2382 #endif
2383
2384   free (gdbtk_file);
2385
2386   discard_cleanups (old_chain);
2387 }
2388
2389 static int
2390 gdb_target_has_execution_command (clientData, interp, argc, argv)
2391      ClientData clientData;
2392      Tcl_Interp *interp;
2393      int argc;
2394      char *argv[];
2395 {
2396   int result = 0;
2397
2398   if (target_has_execution && inferior_pid != 0)
2399     result = 1;
2400
2401   Tcl_SetIntObj (Tcl_GetObjResult (interp), result);
2402   return TCL_OK;
2403 }
2404
2405 static int
2406 gdb_trace_status (clientData, interp, argc, argv)
2407      ClientData clientData;
2408      Tcl_Interp *interp;
2409      int argc;
2410      char *argv[];
2411 {
2412   int result = 0;
2413
2414   if (trace_running_p)
2415     result = 1;
2416
2417   Tcl_SetIntObj (Tcl_GetObjResult (interp), result);
2418   return TCL_OK;
2419 }
2420
2421 /* gdb_load_info - returns information about the file about to be downloaded */
2422
2423 static int
2424 gdb_load_info (clientData, interp, objc, objv)
2425      ClientData clientData;
2426      Tcl_Interp *interp;
2427      int objc;
2428      Tcl_Obj *CONST objv[];
2429 {
2430    bfd *loadfile_bfd;
2431    struct cleanup *old_cleanups;
2432    asection *s;
2433    Tcl_Obj *ob[2];
2434    Tcl_Obj *res[16];
2435    int i = 0;
2436
2437    char *filename = Tcl_GetStringFromObj (objv[1], NULL);
2438
2439    loadfile_bfd = bfd_openr (filename, gnutarget);
2440    if (loadfile_bfd == NULL)
2441      {
2442        Tcl_SetObjResult (interp, Tcl_NewStringObj ("Open failed", -1));
2443        return TCL_ERROR;
2444      }
2445    old_cleanups = make_cleanup (bfd_close, loadfile_bfd);
2446
2447    if (!bfd_check_format (loadfile_bfd, bfd_object))
2448      {
2449        Tcl_SetObjResult (interp, Tcl_NewStringObj ("Bad Object File", -1));
2450        return TCL_ERROR;
2451     }
2452
2453    for (s = loadfile_bfd->sections; s; s = s->next)
2454      {
2455        if (s->flags & SEC_LOAD)
2456          {
2457            bfd_size_type size = bfd_get_section_size_before_reloc (s);
2458            if (size > 0)
2459              {
2460                ob[0] = Tcl_NewStringObj((char *)bfd_get_section_name(loadfile_bfd, s), -1);
2461                ob[1] = Tcl_NewLongObj ((long)size);
2462                res[i++] = Tcl_NewListObj (2, ob);
2463              }
2464          }
2465      }
2466
2467    Tcl_SetObjResult (interp, Tcl_NewListObj (i, res));
2468    do_cleanups (old_cleanups);
2469    return TCL_OK;
2470 }
2471
2472
2473 int
2474 gdbtk_load_hash (section, num)
2475      char *section;
2476      unsigned long num;
2477 {
2478   char buf[128];
2479   sprintf (buf, "download_hash %s %ld", section, num);
2480   Tcl_Eval (interp, buf);
2481   return  atoi (interp->result);
2482 }
2483
2484 /* gdb_get_vars_command -
2485  *
2486  * Implements the "gdb_get_locals" and "gdb_get_args" tcl commands. This
2487  * function sets the Tcl interpreter's result to a list of variable names
2488  * depending on clientData. If clientData is one, the result is a list of
2489  * arguments; zero returns a list of locals -- all relative to the block
2490  * specified as an argument to the command. Valid commands include
2491  * anything decode_line_1 can handle (like "main.c:2", "*0x02020202",
2492  * and "main").
2493  */
2494 static int
2495 gdb_get_vars_command (clientData, interp, objc, objv)
2496      ClientData clientData;
2497      Tcl_Interp *interp;
2498      int objc;
2499      Tcl_Obj *CONST objv[];
2500 {
2501   Tcl_Obj *result;
2502   struct symtabs_and_lines sals;
2503   struct symbol *sym;
2504   struct block *block;
2505   char **canonical, *args;
2506   int i, nsyms, arguments;
2507
2508   if (objc != 2)
2509     {
2510       Tcl_AppendResult (interp,
2511                         "wrong # of args: should be \"",
2512                         Tcl_GetStringFromObj (objv[0], NULL),
2513                         " function:line|function|line|*addr\"");
2514       return TCL_ERROR;
2515     }
2516
2517   arguments = (int) clientData;
2518   args = Tcl_GetStringFromObj (objv[1], NULL);
2519   sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
2520   if (sals.nelts == 0)
2521     {
2522       Tcl_AppendResult (interp,
2523                         "error decoding line", NULL);
2524       return TCL_ERROR;
2525     }
2526
2527   /* Initialize a list that will hold the results */
2528   result = Tcl_NewListObj (0, NULL);
2529
2530   /* Resolve all line numbers to PC's */
2531   for (i = 0; i < sals.nelts; i++)
2532     resolve_sal_pc (&sals.sals[i]);
2533
2534   block = block_for_pc (sals.sals[0].pc);
2535   while (block != 0)
2536     {
2537       nsyms = BLOCK_NSYMS (block);
2538       for (i = 0; i < nsyms; i++)
2539         {
2540           sym = BLOCK_SYM (block, i);
2541           switch (SYMBOL_CLASS (sym)) {
2542           default:
2543           case LOC_UNDEF:                 /* catches errors        */
2544           case LOC_CONST:             /* constant              */
2545           case LOC_STATIC:            /* static                */
2546           case LOC_REGISTER:      /* register              */
2547           case LOC_TYPEDEF:           /* local typedef         */
2548           case LOC_LABEL:             /* local label           */
2549           case LOC_BLOCK:             /* local function        */
2550           case LOC_CONST_BYTES:   /* loc. byte seq.        */
2551           case LOC_UNRESOLVED:    /* unresolved static     */
2552           case LOC_OPTIMIZED_OUT: /* optimized out         */
2553             break;
2554           case LOC_ARG:               /* argument              */
2555           case LOC_REF_ARG:           /* reference arg         */
2556           case LOC_REGPARM:           /* register arg          */
2557           case LOC_REGPARM_ADDR:  /* indirect register arg */
2558           case LOC_LOCAL_ARG:     /* stack arg             */
2559           case LOC_BASEREG_ARG:   /* basereg arg           */
2560             if (arguments)
2561               Tcl_ListObjAppendElement (interp, result,
2562                                         Tcl_NewStringObj (SYMBOL_NAME (sym), -1));
2563             break;
2564           case LOC_LOCAL:             /* stack local           */
2565           case LOC_BASEREG:           /* basereg local         */
2566             if (!arguments)
2567               Tcl_ListObjAppendElement (interp, result,
2568                                         Tcl_NewStringObj (SYMBOL_NAME (sym), -1));
2569             break;
2570           }
2571         }
2572       if (BLOCK_FUNCTION (block))
2573         break;
2574       else
2575         block = BLOCK_SUPERBLOCK (block);
2576     }
2577
2578   Tcl_SetObjResult (interp, result);
2579   return TCL_OK;
2580 }
2581
2582 static int
2583 gdb_get_line_command (clientData, interp, objc, objv)
2584      ClientData clientData;
2585      Tcl_Interp *interp;
2586      int objc;
2587      Tcl_Obj *CONST objv[];
2588 {
2589   Tcl_Obj *result;
2590   struct symtabs_and_lines sals;
2591   char *args, **canonical;
2592
2593   if (objc != 2)
2594     {
2595       Tcl_AppendResult (interp, "wrong # of args: should be \"",
2596                         Tcl_GetStringFromObj (objv[0], NULL),
2597                         " linespec\"");
2598       return TCL_ERROR;
2599     }
2600
2601   args = Tcl_GetStringFromObj (objv[1], NULL);
2602   sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
2603   if (sals.nelts == 1)
2604     {
2605       Tcl_SetObjResult (interp, Tcl_NewIntObj (sals.sals[0].line));
2606       return TCL_OK;
2607     }
2608
2609     Tcl_SetResult (interp, "N/A", TCL_STATIC);
2610     return TCL_OK;
2611 }
2612
2613 static int
2614 gdb_get_file_command (clientData, interp, objc, objv)
2615      ClientData clientData;
2616      Tcl_Interp *interp;
2617      int objc;
2618      Tcl_Obj *CONST objv[];
2619 {
2620   Tcl_Obj *result;
2621   struct symtabs_and_lines sals;
2622   char *args, **canonical;
2623
2624   if (objc != 2)
2625     {
2626       Tcl_AppendResult (interp, "wrong # of args: should be \"",
2627                         Tcl_GetStringFromObj (objv[0], NULL),
2628                         " linespec\"");
2629       return TCL_ERROR;
2630     }
2631
2632   args = Tcl_GetStringFromObj (objv[1], NULL);
2633   sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
2634   if (sals.nelts == 1)
2635     {
2636       Tcl_SetResult (interp, sals.sals[0].symtab->filename, TCL_VOLATILE);
2637       return TCL_OK;
2638     }
2639
2640     Tcl_SetResult (interp, "N/A", TCL_STATIC);
2641     return TCL_OK;
2642 }
2643
2644 static int
2645 gdb_get_function_command (clientData, interp, objc, objv)
2646      ClientData clientData;
2647      Tcl_Interp *interp;
2648      int objc;
2649      Tcl_Obj *CONST objv[];
2650 {
2651   Tcl_Obj *result;
2652   char *function;
2653   struct symtabs_and_lines sals;
2654   char *args, **canonical;
2655
2656   if (objc != 2)
2657     {
2658       Tcl_AppendResult (interp, "wrong # of args: should be \"",
2659                         Tcl_GetStringFromObj (objv[0], NULL),
2660                         " linespec\"");
2661       return TCL_ERROR;
2662     }
2663
2664   args = Tcl_GetStringFromObj (objv[1], NULL);
2665   sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
2666   if (sals.nelts == 1)
2667     {
2668       resolve_sal_pc (&sals.sals[0]);
2669       find_pc_partial_function (sals.sals[0].pc, &function, NULL, NULL);
2670       if (function != NULL)
2671         {
2672           Tcl_SetResult (interp, function, TCL_VOLATILE);
2673           return TCL_OK;
2674         }
2675     }
2676
2677   Tcl_SetResult (interp, "N/A", TCL_STATIC);
2678   return TCL_OK;
2679 }
2680
2681 static int
2682 gdb_get_tracepoint_info (clientData, interp, objc, objv)
2683      ClientData clientData;
2684      Tcl_Interp *interp;
2685      int objc;
2686      Tcl_Obj  *CONST objv[];
2687 {
2688   struct symtab_and_line sal;
2689   int tpnum;
2690   struct tracepoint *tp;
2691   struct action_line *al;
2692   Tcl_Obj *list, *action_list;
2693   char *filename, *funcname;
2694   char tmp[19];
2695
2696   if (objc != 2)
2697     error ("wrong # args");
2698
2699   Tcl_GetIntFromObj (NULL, objv[1], &tpnum);
2700
2701   ALL_TRACEPOINTS (tp)
2702     if (tp->number == tpnum)
2703       break;
2704
2705   if (tp == NULL)
2706     error ("Tracepoint #%d does not exist", tpnum);
2707
2708   list = Tcl_NewListObj (0, NULL);
2709   sal = find_pc_line (tp->address, 0);
2710   filename = symtab_to_filename (sal.symtab);
2711   if (filename == NULL)
2712     filename = "N/A";
2713   Tcl_ListObjAppendElement (interp, list,
2714                             Tcl_NewStringObj (filename, -1));
2715   find_pc_partial_function (tp->address, &funcname, NULL, NULL);
2716   Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj (funcname, -1));
2717   Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (sal.line));
2718   sprintf (tmp, "0x%lx", tp->address);
2719   Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj (tmp, -1));
2720   Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->enabled));
2721   Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->pass_count));
2722   Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->step_count));
2723   Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->thread));
2724   Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->hit_count));
2725
2726   /* Append a list of actions */
2727   action_list = Tcl_NewListObj (0, NULL);
2728   for (al = tp->actions; al != NULL; al = al->next)
2729     {
2730       Tcl_ListObjAppendElement (interp, action_list,
2731                                 Tcl_NewStringObj (al->action, -1));
2732     }
2733   Tcl_ListObjAppendElement (interp, list, action_list);
2734
2735   Tcl_SetObjResult (interp, list);
2736   return TCL_OK;
2737 }
2738
2739
2740 /* TclDebug (const char *fmt, ...) works just like printf() but */
2741 /* sends the output to the GDB TK debug window. */
2742 /* Not for normal use; just a convenient tool for debugging */
2743 void
2744 #ifdef ANSI_PROTOTYPES
2745 TclDebug (const char *fmt, ...)
2746 #else
2747 TclDebug (va_alist)
2748      va_dcl
2749 #endif
2750 {
2751   va_list args;
2752   char buf[512], *v[2], *merge;
2753
2754 #ifdef ANSI_PROTOTYPES
2755   va_start (args, fmt);
2756 #else
2757   char *fmt;
2758   va_start (args);
2759   fmt = va_arg (args, char *);
2760 #endif
2761
2762   v[0] = "debug";
2763   v[1] = buf;
2764
2765   vsprintf (buf, fmt, args);
2766   va_end (args);
2767
2768   merge = Tcl_Merge (2, v);
2769   Tcl_Eval (interp, merge);
2770   Tcl_Free (merge);
2771 }
2772
2773
2774 /* Find the full pathname to a file, searching the symbol tables */
2775
2776 static int
2777 gdb_find_file_command (clientData, interp, objc, objv)
2778   ClientData clientData;
2779   Tcl_Interp *interp;
2780   int objc;
2781   Tcl_Obj *CONST objv[];
2782 {
2783   char *filename = NULL;
2784   struct symtab *st;
2785
2786   if (objc != 2)
2787     {
2788       Tcl_WrongNumArgs(interp, 1, objv, "filename");
2789       return TCL_ERROR;
2790     }
2791
2792   st = full_lookup_symtab (Tcl_GetStringFromObj (objv[1], NULL));
2793   if (st)
2794     filename = st->fullname;
2795
2796   if (filename == NULL)
2797     Tcl_SetObjResult (interp, Tcl_NewStringObj ("", 0));
2798   else
2799     Tcl_SetObjResult (interp, Tcl_NewStringObj (filename, -1));
2800
2801   return TCL_OK;
2802 }
2803
2804 static void
2805 gdbtk_create_tracepoint (tp)
2806   struct tracepoint *tp;
2807 {
2808   tracepoint_notify (tp, "create");
2809 }
2810
2811 static void
2812 gdbtk_delete_tracepoint (tp)
2813   struct tracepoint *tp;
2814 {
2815   tracepoint_notify (tp, "delete");
2816 }
2817
2818 static void
2819 gdbtk_modify_tracepoint (tp)
2820   struct tracepoint *tp;
2821 {
2822   tracepoint_notify (tp, "modify");
2823 }
2824
2825 static void
2826 tracepoint_notify(tp, action)
2827      struct tracepoint *tp;
2828      const char *action;
2829 {
2830   char buf[256];
2831   int v;
2832   struct symtab_and_line sal;
2833   char *filename;
2834
2835   /* We ensure that ACTION contains no special Tcl characters, so we
2836      can do this.  */
2837   sal = find_pc_line (tp->address, 0);
2838
2839   filename = symtab_to_filename (sal.symtab);
2840   if (filename == NULL)
2841     filename = "N/A";
2842   sprintf (buf, "gdbtk_tcl_tracepoint %s %d 0x%lx %d {%s}", action, tp->number,
2843            (long)tp->address, sal.line, filename, tp->pass_count);
2844
2845   v = Tcl_Eval (interp, buf);
2846
2847   if (v != TCL_OK)
2848     {
2849       gdbtk_fputs (interp->result, gdb_stdout);
2850       gdbtk_fputs ("\n", gdb_stdout);
2851     }
2852 }
2853
2854 /* returns -1 if not found, tracepoint # if found */
2855 int
2856 tracepoint_exists (char * args)
2857 {
2858   struct tracepoint *tp;
2859   char **canonical;
2860   struct symtabs_and_lines sals;
2861   char  *file = NULL;
2862   int    result = -1;
2863
2864   sals = decode_line_1 (&args, 1, NULL, 0, &canonical);
2865   if (sals.nelts == 1)
2866     {
2867       resolve_sal_pc (&sals.sals[0]);
2868       file = xmalloc (strlen (sals.sals[0].symtab->dirname)
2869                       + strlen (sals.sals[0].symtab->filename) + 1);
2870       if (file != NULL)
2871         {
2872           strcpy (file, sals.sals[0].symtab->dirname);
2873           strcat (file, sals.sals[0].symtab->filename);
2874
2875           ALL_TRACEPOINTS (tp)
2876             {
2877               if (tp->address == sals.sals[0].pc)
2878                 result = tp->number;
2879 #if 0
2880               /* Why is this here? This messes up assembly traces */
2881               else if (tp->source_file != NULL
2882                        && strcmp (tp->source_file, file) == 0
2883                        && sals.sals[0].line == tp->line_number)
2884                 result = tp->number;
2885 #endif
2886             }
2887         }
2888     }
2889   if (file != NULL)
2890     free (file);
2891   return result;
2892 }
2893
2894 static int
2895 gdb_actions_command (clientData, interp, objc, objv)
2896   ClientData clientData;
2897   Tcl_Interp *interp;
2898   int objc;
2899   Tcl_Obj *CONST objv[];
2900 {
2901   struct tracepoint *tp;
2902   Tcl_Obj **actions;
2903   int      nactions, i, len;
2904   char *number, *args, *action;
2905   long step_count;
2906   struct action_line *next = NULL, *temp;
2907
2908   if (objc != 3)
2909     {
2910       Tcl_AppendResult (interp, "wrong # args: should be: \"",
2911                         Tcl_GetStringFromObj (objv[0], NULL),
2912                         " number actions\"");
2913       return TCL_ERROR;
2914     }
2915
2916   args = number = Tcl_GetStringFromObj (objv[1], NULL);
2917   tp = get_tracepoint_by_number (&args);
2918   if (tp == NULL)
2919     {
2920       Tcl_AppendResult (interp, "Tracepoint \"", number, "\" does not exist");
2921       return TCL_ERROR;
2922     }
2923
2924   /* Free any existing actions */
2925   if (tp->actions != NULL)
2926     free_actions (tp);
2927
2928   step_count = 0;
2929
2930   Tcl_ListObjGetElements (interp, objv[2], &nactions, &actions);
2931   for (i = 0; i < nactions; i++)
2932     {
2933       temp = xmalloc (sizeof (struct action_line));
2934       temp->next = NULL;
2935       action = Tcl_GetStringFromObj (actions[i], &len);
2936       temp->action = savestring (action, len);
2937       if (sscanf (temp->action, "while-stepping %d", &step_count) !=0)
2938         tp->step_count = step_count;
2939       if (next == NULL)
2940         {
2941           tp->actions = temp;
2942           next = temp;
2943         }
2944       else
2945         {
2946           next->next = temp;
2947           next = temp;
2948         }
2949     }
2950
2951   return TCL_OK;
2952 }
2953
2954 static int
2955 gdb_tracepoint_exists_command (clientData, interp, objc, objv)
2956   ClientData clientData;
2957   Tcl_Interp *interp;
2958   int objc;
2959   Tcl_Obj *CONST objv[];
2960 {
2961   char * args;
2962
2963   if (objc != 2)
2964     {
2965       Tcl_AppendResult (interp, "wrong # of args: should be \"",
2966                         Tcl_GetStringFromObj (objv[0], NULL),
2967                         " function:line|function|line|*addr\"");
2968       return TCL_ERROR;
2969     }
2970
2971   args = Tcl_GetStringFromObj (objv[1], NULL);
2972
2973   Tcl_SetObjResult (interp, Tcl_NewIntObj (tracepoint_exists (args)));
2974   return TCL_OK;
2975 }
2976
2977 /* Return the prompt to the interpreter */
2978 static int
2979 gdb_prompt_command (clientData, interp, objc, objv)
2980   ClientData clientData;
2981   Tcl_Interp *interp;
2982   int objc;
2983   Tcl_Obj *CONST objv[];
2984 {
2985   Tcl_SetResult (interp, get_prompt (), TCL_VOLATILE);
2986   return TCL_OK;
2987 }
2988
2989 /* return a list of all tracepoint numbers in interpreter */
2990 static int
2991 gdb_get_tracepoint_list (clientData, interp, objc, objv)
2992   ClientData clientData;
2993   Tcl_Interp *interp;
2994   int objc;
2995   Tcl_Obj *CONST objv[];
2996 {
2997   Tcl_Obj *list;
2998   struct tracepoint *tp;
2999
3000   list = Tcl_NewListObj (0, NULL);
3001
3002   ALL_TRACEPOINTS (tp)
3003     Tcl_ListObjAppendElement (interp, list, Tcl_NewIntObj (tp->number));
3004
3005   Tcl_SetObjResult (interp, list);
3006   return TCL_OK;
3007 }
3008
3009
3010 /* This hook is called whenever we are ready to load a symbol file so that
3011    the UI can notify the user... */
3012 void
3013 gdbtk_pre_add_symbol (name)
3014   char *name;
3015 {
3016   char *merge, *v[2];
3017
3018   v[0] = "gdbtk_tcl_pre_add_symbol";
3019   v[1] = name;
3020   merge = Tcl_Merge (2, v);
3021   Tcl_Eval (interp, merge);
3022   Tcl_Free (merge);
3023 }
3024
3025 /* This hook is called whenever we finish loading a symbol file. */
3026 void
3027 gdbtk_post_add_symbol ()
3028 {
3029   Tcl_Eval (interp, "gdbtk_tcl_post_add_symbol");
3030 }
3031
3032
3033
3034 static void
3035 gdbtk_print_frame_info (s, line, stopline, noerror)
3036   struct symtab *s;
3037   int line;
3038   int stopline;
3039   int noerror;
3040 {
3041   current_source_symtab = s;
3042   current_source_line = line;
3043 }
3044
3045
3046 /* The lookup_symtab() in symtab.c doesn't work correctly */
3047 /* It will not work will full pathnames and if multiple */
3048 /* source files have the same basename, it will return */
3049 /* the first one instead of the correct one.  This version */
3050 /* also always makes sure symtab->fullname is set. */
3051
3052 static struct symtab *
3053 full_lookup_symtab(file)
3054      char *file;
3055 {
3056   struct symtab *st;
3057   struct objfile *objfile;
3058   char *bfile, *fullname;
3059   struct partial_symtab *pt;
3060
3061   if (!file)
3062     return NULL;
3063
3064   /* first try a direct lookup */
3065   st = lookup_symtab (file);
3066   if (st)
3067     {
3068       if (!st->fullname)
3069           symtab_to_filename(st);
3070       return st;
3071     }
3072
3073   /* if the direct approach failed, try */
3074   /* looking up the basename and checking */
3075   /* all matches with the fullname */
3076   bfile = basename (file);
3077   ALL_SYMTABS (objfile, st)
3078     {
3079       if (!strcmp (bfile, basename(st->filename)))
3080         {
3081           if (!st->fullname)
3082             fullname = symtab_to_filename (st);
3083           else
3084             fullname = st->fullname;
3085
3086           if (!strcmp (file, fullname))
3087             return st;
3088         }
3089     }
3090
3091   /* still no luck?  look at psymtabs */
3092   ALL_PSYMTABS (objfile, pt)
3093     {
3094       if (!strcmp (bfile, basename(pt->filename)))
3095         {
3096           st = PSYMTAB_TO_SYMTAB (pt);
3097           if (st)
3098             {
3099               fullname = symtab_to_filename (st);
3100               if (!strcmp (file, fullname))
3101                 return st;
3102             }
3103         }
3104     }
3105   return NULL;
3106 }
3107
3108
3109 /* gdb_loadfile loads a c source file into a text widget. */
3110
3111 /* LTABLE_SIZE is the number of bytes to allocate for the */
3112 /* line table.  Its size limits the maximum number of lines */
3113 /* in a file to 8 * LTABLE_SIZE.  This memory is freed after */
3114 /* the file is loaded, so it is OK to make this very large. */
3115 /* Additional memory will be allocated if needed. */
3116 #define LTABLE_SIZE 20000
3117
3118 static int
3119 gdb_loadfile (clientData, interp, objc, objv)
3120   ClientData clientData;
3121   Tcl_Interp *interp;
3122   int objc;
3123   Tcl_Obj *CONST objv[];
3124 {
3125   char *file, *widget, *line, *buf, msg[128];
3126   int linenumbers, ln, anum, lnum, ltable_size;
3127   Tcl_Obj *a[2], *b[2], *cmd;
3128   FILE *fp;
3129   char *ltable;
3130   struct symtab *symtab;
3131   struct linetable_entry *le;
3132
3133   if (objc != 4)
3134     {
3135       Tcl_WrongNumArgs(interp, 1, objv, "widget filename linenumbers");
3136       return TCL_ERROR;
3137     }
3138
3139   widget = Tcl_GetStringFromObj (objv[1], NULL);
3140   file  = Tcl_GetStringFromObj (objv[2], NULL);
3141   Tcl_GetBooleanFromObj (interp, objv[3], &linenumbers);
3142
3143   if ((fp = fopen ( file, "r" )) == NULL)
3144     return TCL_ERROR;
3145
3146   symtab = full_lookup_symtab (file);
3147   if (!symtab)
3148     {
3149       sprintf(msg, "File not found");
3150       Tcl_SetStringObj ( Tcl_GetObjResult (interp), msg, -1);
3151       fclose (fp);
3152       return TCL_ERROR;
3153     }
3154
3155   /* Source linenumbers don't appear to be in order, and a sort is */
3156   /* too slow so the fastest solution is just to allocate a huge */
3157   /* array and set the array entry for each linenumber */
3158
3159   ltable_size = LTABLE_SIZE;
3160   ltable = (char *)malloc (LTABLE_SIZE);
3161   if (ltable == NULL)
3162     {
3163       sprintf(msg, "Out of memory.");
3164       Tcl_SetStringObj ( Tcl_GetObjResult (interp), msg, -1);
3165       fclose (fp);
3166       return TCL_ERROR;
3167     }
3168
3169   memset (ltable, 0, LTABLE_SIZE);
3170
3171   if (symtab->linetable && symtab->linetable->nitems)
3172     {
3173       le = symtab->linetable->item;
3174       for (ln = symtab->linetable->nitems ;ln > 0; ln--, le++)
3175         {
3176           lnum = le->line >> 3;
3177           if (lnum >= ltable_size)
3178             {
3179               char *new_ltable;
3180               new_ltable = (char *)realloc (ltable, ltable_size*2);
3181               memset (new_ltable + ltable_size, 0, ltable_size);
3182               ltable_size *= 2;
3183               if (new_ltable == NULL)
3184                 {
3185                   sprintf(msg, "Out of memory.");
3186                   Tcl_SetStringObj ( Tcl_GetObjResult (interp), msg, -1);
3187                   free (ltable);
3188                   fclose (fp);
3189                   return TCL_ERROR;
3190                 }
3191               ltable = new_ltable;
3192             }
3193           ltable[lnum] |= 1 << (le->line % 8);
3194         }
3195     }
3196
3197   /* create an object with enough space, then grab its */
3198   /* buffer and sprintf directly into it. */
3199   a[0] = Tcl_NewStringObj (ltable, 1024);
3200   a[1] = Tcl_NewListObj(0,NULL);
3201   buf = a[0]->bytes;
3202   b[0] = Tcl_NewStringObj (ltable,1024);
3203   b[1] = Tcl_NewStringObj ("source_tag", -1);
3204   Tcl_IncrRefCount (b[0]);
3205   Tcl_IncrRefCount (b[1]);
3206   line = b[0]->bytes + 1;
3207   strcpy(b[0]->bytes,"\t");
3208
3209   ln = 1;
3210   while (fgets (line, 980, fp))
3211     {
3212       if (linenumbers)
3213         {
3214           if (ltable[ln >> 3] & (1 << (ln % 8)))
3215         {
3216           sprintf (buf,"%s insert end {-\t%d} break_tag", widget, ln);
3217           a[0]->length = strlen (buf);
3218         }
3219           else
3220         {
3221           sprintf (buf,"%s insert end { \t%d} \"\"", widget, ln);
3222           a[0]->length = strlen (buf);
3223         }
3224         }
3225       else
3226         {
3227           if (ltable[ln >> 3] & (1 << (ln % 8)))
3228         {
3229           sprintf (buf,"%s insert end {-\t} break_tag", widget);
3230           a[0]->length = strlen (buf);
3231         }
3232           else
3233         {
3234           sprintf (buf,"%s insert end { \t} \"\"", widget);
3235           a[0]->length = strlen (buf);
3236         }
3237         }
3238       b[0]->length = strlen(b[0]->bytes);
3239       Tcl_SetListObj(a[1],2,b);
3240       cmd = Tcl_ConcatObj(2,a);
3241       Tcl_EvalObj (interp, cmd);
3242       Tcl_DecrRefCount (cmd);
3243       ln++;
3244     }
3245   Tcl_DecrRefCount (b[0]);
3246   Tcl_DecrRefCount (b[0]);
3247   Tcl_DecrRefCount (b[1]);
3248   Tcl_DecrRefCount (b[1]);
3249   free (ltable);
3250   fclose (fp);
3251   return TCL_OK;
3252 }
3253
3254 /* at some point make these static in breakpoint.c and move GUI code there */
3255 extern struct breakpoint *set_raw_breakpoint (struct symtab_and_line sal);
3256 extern void set_breakpoint_count (int);
3257 extern int breakpoint_count;
3258
3259 /* set a breakpoint by source file and line number */
3260 /* flags are as follows: */
3261 /* least significant 2 bits are disposition, rest is */
3262 /* type (normally 0).
3263
3264 enum bptype {
3265   bp_breakpoint,                 Normal breakpoint
3266   bp_hardware_breakpoint,       Hardware assisted breakpoint
3267 }
3268
3269 Disposition of breakpoint.  Ie: what to do after hitting it.
3270 enum bpdisp {
3271   del,                          Delete it
3272   del_at_next_stop,             Delete at next stop, whether hit or not
3273   disable,                      Disable it
3274   donttouch                     Leave it alone
3275   };
3276 */
3277
3278 static int
3279 gdb_set_bp (clientData, interp, objc, objv)
3280   ClientData clientData;
3281   Tcl_Interp *interp;
3282   int objc;
3283   Tcl_Obj *CONST objv[];
3284
3285 {
3286   struct symtab_and_line sal;
3287   int line, flags, ret;
3288   struct breakpoint *b;
3289   char buf[64];
3290   Tcl_Obj *a[5], *cmd;
3291
3292   if (objc != 4)
3293     {
3294       Tcl_WrongNumArgs(interp, 1, objv, "filename line type");
3295       return TCL_ERROR;
3296     }
3297
3298   sal.symtab = full_lookup_symtab (Tcl_GetStringFromObj( objv[1], NULL));
3299   if (sal.symtab == NULL)
3300     return TCL_ERROR;
3301
3302   if (Tcl_GetIntFromObj( interp, objv[2], &line) == TCL_ERROR)
3303     return TCL_ERROR;
3304
3305   if (Tcl_GetIntFromObj( interp, objv[3], &flags) == TCL_ERROR)
3306     return TCL_ERROR;
3307
3308   sal.line = line;
3309   sal.pc = find_line_pc (sal.symtab, sal.line);
3310   if (sal.pc == 0)
3311     return TCL_ERROR;
3312
3313   sal.section = find_pc_overlay (sal.pc);
3314   b = set_raw_breakpoint (sal);
3315   set_breakpoint_count (breakpoint_count + 1);
3316   b->number = breakpoint_count;
3317   b->type = flags >> 2;
3318   b->disposition = flags & 3;
3319
3320   /* FIXME: this won't work for duplicate basenames! */
3321   sprintf (buf, "%s:%d", basename(Tcl_GetStringFromObj( objv[1], NULL)), line);
3322   b->addr_string = strsave (buf);
3323
3324   /* now send notification command back to GUI */
3325   sprintf (buf, "0x%x", sal.pc);
3326   a[0] = Tcl_NewStringObj ("gdbtk_tcl_breakpoint create", -1);
3327   a[1] = Tcl_NewIntObj (b->number);
3328   a[2] = Tcl_NewStringObj (buf, -1);
3329   a[3] = objv[2];
3330   a[4] = Tcl_NewListObj (1,&objv[1]);
3331   cmd = Tcl_ConcatObj(5,a);
3332   ret = Tcl_EvalObj (interp, cmd);
3333   Tcl_DecrRefCount (cmd);
3334   return ret;
3335 }
3336
3337 #ifdef __CYGWIN32__
3338 /* The whole timer idea is an easy one, but POSIX does not appear to have
3339    some sort of interval timer requirement. Consequently, we cannot rely
3340    on cygwin32 to always deliver the timer's signal. This is especially
3341    painful given that all serial I/O will block the timer right now. */
3342 static void
3343 gdbtk_annotate_starting ()
3344 {
3345   /* TclDebug ("### STARTING ###"); */
3346   gdbtk_start_timer ();
3347 }
3348
3349 static void
3350 gdbtk_annotate_stopped ()
3351 {
3352   /* TclDebug ("### STOPPED ###"); */
3353   gdbtk_stop_timer ();
3354 }
3355
3356 static void
3357 gdbtk_annotate_exited ()
3358 {
3359   /* TclDebug ("### EXITED ###"); */
3360   gdbtk_stop_timer ();
3361 }
3362
3363 static void
3364 gdbtk_annotate_signalled ()
3365 {
3366   /* TclDebug ("### SIGNALLED ###"); */
3367   gdbtk_stop_timer ();
3368 }
3369 #endif
3370
3371 /* Come here during initialize_all_files () */
3372
3373 void
3374 _initialize_gdbtk ()
3375 {
3376   if (use_windows)
3377     {
3378       /* Tell the rest of the world that Gdbtk is now set up. */
3379
3380       init_ui_hook = gdbtk_init;
3381     }
3382 }