gdb/gdbtk.c

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