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