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