gdb/gdbtk.c

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