gdb/gdbtk.c

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