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